home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / generic / tclTest.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  75.4 KB  |  2,626 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tclTest.c --
  3.  *
  4.  *    This file contains C command procedures for a bunch of additional
  5.  *    Tcl commands that are used for testing out Tcl's C interfaces.
  6.  *    These commands are not normally included in Tcl applications;
  7.  *    they're only used for testing.
  8.  *
  9.  * Copyright (c) 1993-1994 The Regents of the University of California.
  10.  * Copyright (c) 1994-1997 Sun Microsystems, Inc.
  11.  *
  12.  * See the file "license.terms" for information on usage and redistribution
  13.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14.  *
  15.  * SCCS: @(#) tclTest.c 1.115 97/08/13 10:27:26
  16.  */
  17.  
  18. #define TCL_TEST
  19.  
  20. #include "tclInt.h"
  21. #include "tclPort.h"
  22.  
  23. /*
  24.  * Declare external functions used in Windows tests.
  25.  */
  26.  
  27. #if defined(__WIN32__)
  28. extern TclPlatformType *    TclWinGetPlatform _ANSI_ARGS_((void));
  29. #endif
  30.  
  31. /*
  32.  * Dynamic string shared by TestdcallCmd and DelCallbackProc;  used
  33.  * to collect the results of the various deletion callbacks.
  34.  */
  35.  
  36. static Tcl_DString delString;
  37. static Tcl_Interp *delInterp;
  38.  
  39. /*
  40.  * One of the following structures exists for each asynchronous
  41.  * handler created by the "testasync" command".
  42.  */
  43.  
  44. typedef struct TestAsyncHandler {
  45.     int id;                /* Identifier for this handler. */
  46.     Tcl_AsyncHandler handler;        /* Tcl's token for the handler. */
  47.     char *command;            /* Command to invoke when the
  48.                      * handler is invoked. */
  49.     struct TestAsyncHandler *nextPtr;    /* Next is list of handlers. */
  50. } TestAsyncHandler;
  51.  
  52. static TestAsyncHandler *firstHandler = NULL;
  53.  
  54. /*
  55.  * The dynamic string below is used by the "testdstring" command
  56.  * to test the dynamic string facilities.
  57.  */
  58.  
  59. static Tcl_DString dstring;
  60.  
  61. /*
  62.  * One of the following structures exists for each command created
  63.  * by TestdelCmd:
  64.  */
  65.  
  66. typedef struct DelCmd {
  67.     Tcl_Interp *interp;        /* Interpreter in which command exists. */
  68.     char *deleteCmd;        /* Script to execute when command is
  69.                  * deleted.  Malloc'ed. */
  70. } DelCmd;
  71.  
  72. /*
  73.  * Forward declarations for procedures defined later in this file:
  74.  */
  75.  
  76. int            Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));
  77. static int        AsyncHandlerProc _ANSI_ARGS_((ClientData clientData,
  78.                 Tcl_Interp *interp, int code));
  79. static void        CleanupTestSetassocdataTests _ANSI_ARGS_((
  80.                 ClientData clientData, Tcl_Interp *interp));
  81. static void        CmdDelProc1 _ANSI_ARGS_((ClientData clientData));
  82. static void        CmdDelProc2 _ANSI_ARGS_((ClientData clientData));
  83. static int        CmdProc1 _ANSI_ARGS_((ClientData clientData,
  84.                 Tcl_Interp *interp, int argc, char **argv));
  85. static int        CmdProc2 _ANSI_ARGS_((ClientData clientData,
  86.                 Tcl_Interp *interp, int argc, char **argv));
  87. static void        CmdTraceProc _ANSI_ARGS_((ClientData clientData,
  88.                 Tcl_Interp *interp, int level, char *command,
  89.                 Tcl_CmdProc *cmdProc, ClientData cmdClientData,
  90.                             int argc, char **argv));
  91. static int        CreatedCommandProc _ANSI_ARGS_((
  92.                 ClientData clientData, Tcl_Interp *interp,
  93.                 int argc, char **argv));
  94. static int        CreatedCommandProc2 _ANSI_ARGS_((
  95.                 ClientData clientData, Tcl_Interp *interp,
  96.                 int argc, char **argv));
  97. static void        DelCallbackProc _ANSI_ARGS_((ClientData clientData,
  98.                 Tcl_Interp *interp));
  99. static int        DelCmdProc _ANSI_ARGS_((ClientData clientData,
  100.                 Tcl_Interp *interp, int argc, char **argv));
  101. static void        DelDeleteProc _ANSI_ARGS_((ClientData clientData));
  102. static void        ExitProcEven _ANSI_ARGS_((ClientData clientData));
  103. static void        ExitProcOdd _ANSI_ARGS_((ClientData clientData));
  104. static int              GetTimesCmd _ANSI_ARGS_((ClientData clientData,
  105.                             Tcl_Interp *interp, int argc, char **argv));
  106. static int              NoopCmd _ANSI_ARGS_((ClientData clientData,
  107.                             Tcl_Interp *interp, int argc, char **argv));
  108. static int              NoopObjCmd _ANSI_ARGS_((ClientData clientData,
  109.                             Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
  110. static void        SpecialFree _ANSI_ARGS_((char *blockPtr));
  111. static int        StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp));
  112. static int        TestasyncCmd _ANSI_ARGS_((ClientData dummy,
  113.                 Tcl_Interp *interp, int argc, char **argv));
  114. static int        TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy,
  115.                 Tcl_Interp *interp, int argc, char **argv));
  116. static int        TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy,
  117.                 Tcl_Interp *interp, int argc, char **argv));
  118. static int        TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy,
  119.                 Tcl_Interp *interp, int argc, char **argv));
  120. static int        TestchmodCmd _ANSI_ARGS_((ClientData dummy,
  121.                 Tcl_Interp *interp, int argc, char **argv));
  122. static int        TestcreatecommandCmd _ANSI_ARGS_((ClientData dummy,
  123.                 Tcl_Interp *interp, int argc, char **argv));
  124. static int        TestdcallCmd _ANSI_ARGS_((ClientData dummy,
  125.                 Tcl_Interp *interp, int argc, char **argv));
  126. static int        TestdelCmd _ANSI_ARGS_((ClientData dummy,
  127.                 Tcl_Interp *interp, int argc, char **argv));
  128. static int        TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy,
  129.                 Tcl_Interp *interp, int argc, char **argv));
  130. static int        TestdstringCmd _ANSI_ARGS_((ClientData dummy,
  131.                 Tcl_Interp *interp, int argc, char **argv));
  132. static int        TestexithandlerCmd _ANSI_ARGS_((ClientData dummy,
  133.                 Tcl_Interp *interp, int argc, char **argv));
  134. static int        TestexprlongCmd _ANSI_ARGS_((ClientData dummy,
  135.                 Tcl_Interp *interp, int argc, char **argv));
  136. static int        TestexprstringCmd _ANSI_ARGS_((ClientData dummy,
  137.                 Tcl_Interp *interp, int argc, char **argv));
  138. static int        TestfileCmd _ANSI_ARGS_((ClientData dummy,
  139.                 Tcl_Interp *interp, int argc, char **argv));
  140. static int        TestfeventCmd _ANSI_ARGS_((ClientData dummy,
  141.                 Tcl_Interp *interp, int argc, char **argv));
  142. static int        TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy,
  143.                 Tcl_Interp *interp, int argc, char **argv));
  144. static int        TestgetplatformCmd _ANSI_ARGS_((ClientData dummy,
  145.                 Tcl_Interp *interp, int argc, char **argv));
  146. static int        TestgetvarfullnameCmd _ANSI_ARGS_((
  147.                 ClientData dummy, Tcl_Interp *interp,
  148.                 int objc, Tcl_Obj *CONST objv[]));
  149. static int        TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy,
  150.                     Tcl_Interp *interp, int argc, char **argv));
  151. static int        TestlinkCmd _ANSI_ARGS_((ClientData dummy,
  152.                 Tcl_Interp *interp, int argc, char **argv));
  153. static int        TestMathFunc _ANSI_ARGS_((ClientData clientData,
  154.                 Tcl_Interp *interp, Tcl_Value *args,
  155.                 Tcl_Value *resultPtr));
  156. static int        TestMathFunc2 _ANSI_ARGS_((ClientData clientData,
  157.                 Tcl_Interp *interp, Tcl_Value *args,
  158.                 Tcl_Value *resultPtr));
  159. static int        TestPanicCmd _ANSI_ARGS_((ClientData dummy,
  160.                 Tcl_Interp *interp, int argc, char **argv));
  161. static int        TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy,
  162.                 Tcl_Interp *interp, int argc, char **argv));
  163. static int        TestsetnoerrCmd _ANSI_ARGS_((ClientData dummy,
  164.                     Tcl_Interp *interp, int argc, char **argv));
  165. static int        TestsetobjerrorcodeCmd _ANSI_ARGS_((
  166.                 ClientData dummy, Tcl_Interp *interp,
  167.                 int objc, Tcl_Obj *CONST objv[]));
  168. static int        TestsetplatformCmd _ANSI_ARGS_((ClientData dummy,
  169.                 Tcl_Interp *interp, int argc, char **argv));
  170. static int        TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy,
  171.                 Tcl_Interp *interp, int argc, char **argv));
  172. static int        TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy,
  173.                 Tcl_Interp *interp, int argc, char **argv));
  174. static int        TestupvarCmd _ANSI_ARGS_((ClientData dummy,
  175.                 Tcl_Interp *interp, int argc, char **argv));
  176. static int        TestwordendObjCmd _ANSI_ARGS_((ClientData dummy,
  177.                 Tcl_Interp *interp, int objc,
  178.                 Tcl_Obj *CONST objv[]));
  179.  
  180. /*
  181.  * External (platform specific) initialization routine:
  182.  */
  183.  
  184. EXTERN int        TclplatformtestInit _ANSI_ARGS_((
  185.                 Tcl_Interp *interp));
  186.  
  187. /*
  188.  *----------------------------------------------------------------------
  189.  *
  190.  * Tcltest_Init --
  191.  *
  192.  *    This procedure performs application-specific initialization.
  193.  *    Most applications, especially those that incorporate additional
  194.  *    packages, will have their own version of this procedure.
  195.  *
  196.  * Results:
  197.  *    Returns a standard Tcl completion code, and leaves an error
  198.  *    message in interp->result if an error occurs.
  199.  *
  200.  * Side effects:
  201.  *    Depends on the startup script.
  202.  *
  203.  *----------------------------------------------------------------------
  204.  */
  205.  
  206. int
  207. Tcltest_Init(interp)
  208.     Tcl_Interp *interp;        /* Interpreter for application. */
  209. {
  210.     Tcl_ValueType t3ArgTypes[2];
  211.     
  212.     if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) {
  213.         return TCL_ERROR;
  214.     }
  215.  
  216.     /*
  217.      * Create additional commands and math functions for testing Tcl.
  218.      */
  219.  
  220.     Tcl_CreateCommand(interp, "noop", NoopCmd, (ClientData) 0,
  221.         (Tcl_CmdDeleteProc *) NULL);
  222.     Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, (ClientData) 0,
  223.         (Tcl_CmdDeleteProc *) NULL);
  224.     Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0,
  225.         (Tcl_CmdDeleteProc *) NULL);
  226.     Tcl_CreateCommand(interp, "testchannel", TclTestChannelCmd,
  227.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  228.     Tcl_CreateCommand(interp, "testchannelevent", TclTestChannelEventCmd,
  229.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  230.     Tcl_CreateCommand(interp, "testchmod", TestchmodCmd,
  231.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  232.     Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (ClientData) 0,
  233.         (Tcl_CmdDeleteProc *) NULL);
  234.     Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0,
  235.         (Tcl_CmdDeleteProc *) NULL);
  236.     Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd,
  237.         (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  238.     Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd,
  239.         (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  240.     Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0,
  241.         (Tcl_CmdDeleteProc *) NULL);
  242.     Tcl_CreateCommand(interp, "testdel", TestdelCmd, (ClientData) 0,
  243.         (Tcl_CmdDeleteProc *) NULL);
  244.     Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd,
  245.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  246.     Tcl_DStringInit(&dstring);
  247.     Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0,
  248.         (Tcl_CmdDeleteProc *) NULL);
  249.     Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd,
  250.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  251.     Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd,
  252.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  253.     Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd,
  254.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  255.     Tcl_CreateCommand(interp, "testfile", TestfileCmd,
  256.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  257.     Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
  258.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  259.     Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
  260.         (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  261.     Tcl_CreateObjCommand(interp, "testgetvarfullname",
  262.         TestgetvarfullnameCmd, (ClientData) 0,
  263.         (Tcl_CmdDeleteProc *) NULL);
  264.     Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd,
  265.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  266.     Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0,
  267.         (Tcl_CmdDeleteProc *) NULL);
  268.     Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
  269.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  270.     Tcl_CreateCommand(interp, "testsetnoerr", TestsetnoerrCmd,
  271.             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  272.     Tcl_CreateObjCommand(interp, "testsetobjerrorcode", 
  273.         TestsetobjerrorcodeCmd, (ClientData) 0,
  274.         (Tcl_CmdDeleteProc *) NULL);
  275.     Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
  276.         (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  277.     Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
  278.         (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  279.     Tcl_CreateCommand(interp, "testtranslatefilename",
  280.             TesttranslatefilenameCmd, (ClientData) 0,
  281.             (Tcl_CmdDeleteProc *) NULL);
  282.     Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0,
  283.         (Tcl_CmdDeleteProc *) NULL);
  284.     Tcl_CreateObjCommand(interp, "testwordend", TestwordendObjCmd,
  285.         (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
  286.     Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0,
  287.             (Tcl_CmdDeleteProc *) NULL);
  288.     Tcl_CreateCommand(interp, "testpanic", TestPanicCmd, (ClientData) 0,
  289.             (Tcl_CmdDeleteProc *) NULL);
  290.     Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, (ClientData) 0,
  291.         (Tcl_CmdDeleteProc *) NULL);
  292.     Tcl_CreateMathFunc(interp, "T1", 0, (Tcl_ValueType *) NULL, TestMathFunc,
  293.         (ClientData) 123);
  294.     Tcl_CreateMathFunc(interp, "T2", 0, (Tcl_ValueType *) NULL, TestMathFunc,
  295.         (ClientData) 345);
  296.     t3ArgTypes[0] = TCL_EITHER;
  297.     t3ArgTypes[1] = TCL_EITHER;
  298.     Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
  299.         (ClientData) 0);
  300.  
  301.     /*
  302.      * And finally add any platform specific test commands.
  303.      */
  304.     
  305.     return TclplatformtestInit(interp);
  306. }
  307.  
  308. /*
  309.  *----------------------------------------------------------------------
  310.  *
  311.  * TestasyncCmd --
  312.  *
  313.  *    This procedure implements the "testasync" command.  It is used
  314.  *    to test the asynchronous handler facilities of Tcl.
  315.  *
  316.  * Results:
  317.  *    A standard Tcl result.
  318.  *
  319.  * Side effects:
  320.  *    Creates, deletes, and invokes handlers.
  321.  *
  322.  *----------------------------------------------------------------------
  323.  */
  324.  
  325.     /* ARGSUSED */
  326. static int
  327. TestasyncCmd(dummy, interp, argc, argv)
  328.     ClientData dummy;            /* Not used. */
  329.     Tcl_Interp *interp;            /* Current interpreter. */
  330.     int argc;                /* Number of arguments. */
  331.     char **argv;            /* Argument strings. */
  332. {
  333.     TestAsyncHandler *asyncPtr, *prevPtr;
  334.     int id, code;
  335.     static int nextId = 1;
  336.     char buf[30];
  337.  
  338.     if (argc < 2) {
  339.     wrongNumArgs:
  340.     Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
  341.     return TCL_ERROR;
  342.     }
  343.     if (strcmp(argv[1], "create") == 0) {
  344.     if (argc != 3) {
  345.         goto wrongNumArgs;
  346.     }
  347.     asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler));
  348.     asyncPtr->id = nextId;
  349.     nextId++;
  350.     asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc,
  351.         (ClientData) asyncPtr);
  352.     asyncPtr->command = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1));
  353.     strcpy(asyncPtr->command, argv[2]);
  354.     asyncPtr->nextPtr = firstHandler;
  355.     firstHandler = asyncPtr;
  356.     sprintf(buf, "%d", asyncPtr->id);
  357.     Tcl_SetResult(interp, buf, TCL_VOLATILE);
  358.     } else if (strcmp(argv[1], "delete") == 0) {
  359.     if (argc == 2) {
  360.         while (firstHandler != NULL) {
  361.         asyncPtr = firstHandler;
  362.         firstHandler = asyncPtr->nextPtr;
  363.         Tcl_AsyncDelete(asyncPtr->handler);
  364.         ckfree(asyncPtr->command);
  365.         ckfree((char *) asyncPtr);
  366.         }
  367.         return TCL_OK;
  368.     }
  369.     if (argc != 3) {
  370.         goto wrongNumArgs;
  371.     }
  372.     if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {
  373.         return TCL_ERROR;
  374.     }
  375.     for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL;
  376.         prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) {
  377.         if (asyncPtr->id != id) {
  378.         continue;
  379.         }
  380.         if (prevPtr == NULL) {
  381.         firstHandler = asyncPtr->nextPtr;
  382.         } else {
  383.         prevPtr->nextPtr = asyncPtr->nextPtr;
  384.         }
  385.         Tcl_AsyncDelete(asyncPtr->handler);
  386.         ckfree(asyncPtr->command);
  387.         ckfree((char *) asyncPtr);
  388.         break;
  389.     }
  390.     } else if (strcmp(argv[1], "mark") == 0) {
  391.     if (argc != 5) {
  392.         goto wrongNumArgs;
  393.     }
  394.     if ((Tcl_GetInt(interp, argv[2], &id) != TCL_OK)
  395.         || (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) {
  396.         return TCL_ERROR;
  397.     }
  398.     for (asyncPtr = firstHandler; asyncPtr != NULL;
  399.         asyncPtr = asyncPtr->nextPtr) {
  400.         if (asyncPtr->id == id) {
  401.         Tcl_AsyncMark(asyncPtr->handler);
  402.         break;
  403.         }
  404.     }
  405.     Tcl_SetResult(interp, argv[3], TCL_VOLATILE);
  406.     return code;
  407.     } else {
  408.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  409.         "\": must be create, delete, int, or mark",
  410.         (char *) NULL);
  411.     return TCL_ERROR;
  412.     }
  413.     return TCL_OK;
  414. }
  415.  
  416. static int
  417. AsyncHandlerProc(clientData, interp, code)
  418.     ClientData clientData;    /* Pointer to TestAsyncHandler structure. */
  419.     Tcl_Interp *interp;        /* Interpreter in which command was
  420.                  * executed, or NULL. */
  421.     int code;            /* Current return code from command. */
  422. {
  423.     TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData;
  424.     char *listArgv[4];
  425.     char string[20], *cmd;
  426.  
  427.     sprintf(string, "%d", code);
  428.     listArgv[0] = asyncPtr->command;
  429.     listArgv[1] = interp->result;
  430.     listArgv[2] = string;
  431.     listArgv[3] = NULL;
  432.     cmd = Tcl_Merge(3, listArgv);
  433.     code = Tcl_Eval(interp, cmd);
  434.     ckfree(cmd);
  435.     return code;
  436. }
  437.  
  438. /*
  439.  *----------------------------------------------------------------------
  440.  *
  441.  * TestcmdinfoCmd --
  442.  *
  443.  *    This procedure implements the "testcmdinfo" command.  It is used
  444.  *    to test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation
  445.  *    and deletion.
  446.  *
  447.  * Results:
  448.  *    A standard Tcl result.
  449.  *
  450.  * Side effects:
  451.  *    Creates and deletes various commands and modifies their data.
  452.  *
  453.  *----------------------------------------------------------------------
  454.  */
  455.  
  456.     /* ARGSUSED */
  457. static int
  458. TestcmdinfoCmd(dummy, interp, argc, argv)
  459.     ClientData dummy;            /* Not used. */
  460.     Tcl_Interp *interp;            /* Current interpreter. */
  461.     int argc;                /* Number of arguments. */
  462.     char **argv;            /* Argument strings. */
  463. {
  464.     Tcl_CmdInfo info;
  465.  
  466.     if (argc != 3) {
  467.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  468.         " option cmdName\"", (char *) NULL);
  469.     return TCL_ERROR;
  470.     }
  471.     if (strcmp(argv[1], "create") == 0) {
  472.     Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original",
  473.         CmdDelProc1);
  474.     } else if (strcmp(argv[1], "delete") == 0) {
  475.     Tcl_DStringInit(&delString);
  476.     Tcl_DeleteCommand(interp, argv[2]);
  477.     Tcl_DStringResult(interp, &delString);
  478.     } else if (strcmp(argv[1], "get") == 0) {
  479.     if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) {
  480.         Tcl_SetResult(interp, "??", TCL_STATIC);
  481.         return TCL_OK;
  482.     }
  483.     if (info.proc == CmdProc1) {
  484.         Tcl_AppendResult(interp, "CmdProc1", " ",
  485.             (char *) info.clientData, (char *) NULL);
  486.     } else if (info.proc == CmdProc2) {
  487.         Tcl_AppendResult(interp, "CmdProc2", " ",
  488.             (char *) info.clientData, (char *) NULL);
  489.     } else {
  490.         Tcl_AppendResult(interp, "unknown", (char *) NULL);
  491.     }
  492.     if (info.deleteProc == CmdDelProc1) {
  493.         Tcl_AppendResult(interp, " CmdDelProc1", " ",
  494.             (char *) info.deleteData, (char *) NULL);
  495.     } else if (info.deleteProc == CmdDelProc2) {
  496.         Tcl_AppendResult(interp, " CmdDelProc2", " ",
  497.             (char *) info.deleteData, (char *) NULL);
  498.     } else {
  499.         Tcl_AppendResult(interp, " unknown", (char *) NULL);
  500.     }
  501.     Tcl_AppendResult(interp, " ", info.namespacePtr->fullName,
  502.             (char *) NULL);
  503.     if (info.isNativeObjectProc) {
  504.         Tcl_AppendResult(interp, " nativeObjectProc", (char *) NULL);
  505.     } else {
  506.         Tcl_AppendResult(interp, " stringProc", (char *) NULL);
  507.     }
  508.     } else if (strcmp(argv[1], "modify") == 0) {
  509.     info.proc = CmdProc2;
  510.     info.clientData = (ClientData) "new_command_data";
  511.     info.objProc = NULL;
  512.         info.objClientData = (ClientData) NULL;
  513.     info.deleteProc = CmdDelProc2;
  514.     info.deleteData = (ClientData) "new_delete_data";
  515.     if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) {
  516.         Tcl_SetResult(interp, "0", TCL_STATIC);
  517.     } else {
  518.         Tcl_SetResult(interp, "1", TCL_STATIC);
  519.     }
  520.     } else {
  521.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  522.         "\": must be create, delete, get, or modify",
  523.         (char *) NULL);
  524.     return TCL_ERROR;
  525.     }
  526.     return TCL_OK;
  527. }
  528.  
  529.     /*ARGSUSED*/
  530. static int
  531. CmdProc1(clientData, interp, argc, argv)
  532.     ClientData clientData;        /* String to return. */
  533.     Tcl_Interp *interp;            /* Current interpreter. */
  534.     int argc;                /* Number of arguments. */
  535.     char **argv;            /* Argument strings. */
  536. {
  537.     Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData,
  538.         (char *) NULL);
  539.     return TCL_OK;
  540. }
  541.  
  542.     /*ARGSUSED*/
  543. static int
  544. CmdProc2(clientData, interp, argc, argv)
  545.     ClientData clientData;        /* String to return. */
  546.     Tcl_Interp *interp;            /* Current interpreter. */
  547.     int argc;                /* Number of arguments. */
  548.     char **argv;            /* Argument strings. */
  549. {
  550.     Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData,
  551.         (char *) NULL);
  552.     return TCL_OK;
  553. }
  554.  
  555. static void
  556. CmdDelProc1(clientData)
  557.     ClientData clientData;        /* String to save. */
  558. {
  559.     Tcl_DStringInit(&delString);
  560.     Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1);
  561.     Tcl_DStringAppend(&delString, (char *) clientData, -1);
  562. }
  563.  
  564. static void
  565. CmdDelProc2(clientData)
  566.     ClientData clientData;        /* String to save. */
  567. {
  568.     Tcl_DStringInit(&delString);
  569.     Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1);
  570.     Tcl_DStringAppend(&delString, (char *) clientData, -1);
  571. }
  572.  
  573. /*
  574.  *----------------------------------------------------------------------
  575.  *
  576.  * TestcmdtokenCmd --
  577.  *
  578.  *    This procedure implements the "testcmdtoken" command. It is used
  579.  *    to test Tcl_Command tokens and procedures such as
  580.  *    Tcl_GetCommandFullName.
  581.  *
  582.  * Results:
  583.  *    A standard Tcl result.
  584.  *
  585.  * Side effects:
  586.  *    Creates and deletes various commands and modifies their data.
  587.  *
  588.  *----------------------------------------------------------------------
  589.  */
  590.  
  591.     /* ARGSUSED */
  592. static int
  593. TestcmdtokenCmd(dummy, interp, argc, argv)
  594.     ClientData dummy;            /* Not used. */
  595.     Tcl_Interp *interp;            /* Current interpreter. */
  596.     int argc;                /* Number of arguments. */
  597.     char **argv;            /* Argument strings. */
  598. {
  599.     Tcl_Command token;
  600.     long int l;
  601.     char buf[30];
  602.  
  603.     if (argc != 3) {
  604.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  605.         " option arg\"", (char *) NULL);
  606.     return TCL_ERROR;
  607.     }
  608.     if (strcmp(argv[1], "create") == 0) {
  609.     token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
  610.         (ClientData) "original", (Tcl_CmdDeleteProc *) NULL);
  611.     sprintf(buf, "%lx", (long int) token);
  612.     Tcl_SetResult(interp, buf, TCL_VOLATILE);
  613.     } else if (strcmp(argv[1], "name") == 0) {
  614.     Tcl_Obj *objPtr;
  615.     
  616.     if (sscanf(argv[2], "%lx", &l) != 1) {
  617.         Tcl_AppendResult(interp, "bad command token \"", argv[2],
  618.             "\"", (char *) NULL);
  619.         return TCL_ERROR;
  620.     }
  621.  
  622.     objPtr = Tcl_NewObj();
  623.     Tcl_GetCommandFullName(interp, (Tcl_Command) l, objPtr);
  624.     
  625.     Tcl_AppendElement(interp,
  626.             Tcl_GetCommandName(interp, (Tcl_Command) l));
  627.     Tcl_AppendElement(interp,
  628.         Tcl_GetStringFromObj(objPtr, (int *) NULL));
  629.     Tcl_DecrRefCount(objPtr);
  630.     } else {
  631.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  632.         "\": must be create or name", (char *) NULL);
  633.     return TCL_ERROR;
  634.     }
  635.     return TCL_OK;
  636. }
  637.  
  638. /*
  639.  *----------------------------------------------------------------------
  640.  *
  641.  * TestcmdtraceCmd --
  642.  *
  643.  *    This procedure implements the "testcmdtrace" command. It is used
  644.  *    to test Tcl_CreateTrace and Tcl_DeleteTrace.
  645.  *
  646.  * Results:
  647.  *    A standard Tcl result.
  648.  *
  649.  * Side effects:
  650.  *    Creates and deletes a command trace, and tests the invocation of
  651.  *    a procedure by the command trace.
  652.  *
  653.  *----------------------------------------------------------------------
  654.  */
  655.  
  656.     /* ARGSUSED */
  657. static int
  658. TestcmdtraceCmd(dummy, interp, argc, argv)
  659.     ClientData dummy;            /* Not used. */
  660.     Tcl_Interp *interp;            /* Current interpreter. */
  661.     int argc;                /* Number of arguments. */
  662.     char **argv;            /* Argument strings. */
  663. {
  664.     Tcl_Trace trace;
  665.     Tcl_DString buffer;
  666.     int result;
  667.  
  668.     if (argc != 2) {
  669.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  670.         " script\"", (char *) NULL);
  671.     return TCL_ERROR;
  672.     }
  673.  
  674.     Tcl_DStringInit(&buffer);
  675.     trace = Tcl_CreateTrace(interp, 50000,
  676.         (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
  677.  
  678.     result = Tcl_Eval(interp, argv[1]);
  679.     if (result == TCL_OK) {
  680.     Tcl_ResetResult(interp);
  681.     Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
  682.     }
  683.     
  684.     Tcl_DeleteTrace(interp, trace);
  685.     Tcl_DStringFree(&buffer);
  686.     return TCL_OK;
  687. }
  688.  
  689. static void
  690. CmdTraceProc(clientData, interp, level, command, cmdProc, cmdClientData,
  691.         argc, argv)
  692.     ClientData clientData;    /* Pointer to buffer in which the
  693.                  * command and arguments are appended.
  694.                  * Accumulates test result. */
  695.     Tcl_Interp *interp;        /* Current interpreter. */
  696.     int level;            /* Current trace level. */
  697.     char *command;        /* The command being traced (after
  698.                  * substitutions). */
  699.     Tcl_CmdProc *cmdProc;    /* Points to command's command procedure. */
  700.     ClientData cmdClientData;    /* Client data associated with command
  701.                  * procedure. */
  702.     int argc;            /* Number of arguments. */
  703.     char **argv;        /* Argument strings. */
  704. {
  705.     Tcl_DString *bufPtr = (Tcl_DString *) clientData;
  706.     int i;
  707.  
  708.     Tcl_DStringAppendElement(bufPtr, command);
  709.  
  710.     Tcl_DStringStartSublist(bufPtr);
  711.     for (i = 0;  i < argc;  i++) {
  712.     Tcl_DStringAppendElement(bufPtr, argv[i]);
  713.     }
  714.     Tcl_DStringEndSublist(bufPtr);
  715. }
  716.  
  717. /*
  718.  *----------------------------------------------------------------------
  719.  *
  720.  * TestcreatecommandCmd --
  721.  *
  722.  *    This procedure implements the "testcreatecommand" command. It is
  723.  *    used to test that the Tcl_CreateCommand creates a new command in
  724.  *    the namespace specified as part of its name, if any. It also
  725.  *    checks that the namespace code ignore single ":"s in the middle
  726.  *    or end of a command name.
  727.  *
  728.  * Results:
  729.  *    A standard Tcl result.
  730.  *
  731.  * Side effects:
  732.  *    Creates and deletes two commands ("test_ns_basic::createdcommand"
  733.  *    and "value:at:").
  734.  *
  735.  *----------------------------------------------------------------------
  736.  */
  737.  
  738. static int
  739. TestcreatecommandCmd(dummy, interp, argc, argv)
  740.     ClientData dummy;            /* Not used. */
  741.     Tcl_Interp *interp;            /* Current interpreter. */
  742.     int argc;                /* Number of arguments. */
  743.     char **argv;            /* Argument strings. */
  744. {
  745.     if (argc != 2) {
  746.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  747.         " option\"", (char *) NULL);
  748.     return TCL_ERROR;
  749.     }
  750.     if (strcmp(argv[1], "create") == 0) {
  751.     Tcl_CreateCommand(interp, "test_ns_basic::createdcommand",
  752.         CreatedCommandProc, (ClientData) NULL,
  753.         (Tcl_CmdDeleteProc *) NULL);
  754.     } else if (strcmp(argv[1], "delete") == 0) {
  755.     Tcl_DeleteCommand(interp, "test_ns_basic::createdcommand");
  756.     } else if (strcmp(argv[1], "create2") == 0) {
  757.     Tcl_CreateCommand(interp, "value:at:",
  758.         CreatedCommandProc2, (ClientData) NULL,
  759.         (Tcl_CmdDeleteProc *) NULL);
  760.     } else if (strcmp(argv[1], "delete2") == 0) {
  761.     Tcl_DeleteCommand(interp, "value:at:");
  762.     } else {
  763.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  764.         "\": must be create, delete, create2, or delete2",
  765.         (char *) NULL);
  766.     return TCL_ERROR;
  767.     }
  768.     return TCL_OK;
  769. }
  770.  
  771. static int
  772. CreatedCommandProc(clientData, interp, argc, argv)
  773.     ClientData clientData;        /* String to return. */
  774.     Tcl_Interp *interp;            /* Current interpreter. */
  775.     int argc;                /* Number of arguments. */
  776.     char **argv;            /* Argument strings. */
  777. {
  778.     Tcl_CmdInfo info;
  779.     int found;
  780.  
  781.     found = Tcl_GetCommandInfo(interp, "test_ns_basic::createdcommand",
  782.         &info);
  783.     if (!found) {
  784.     Tcl_AppendResult(interp, "CreatedCommandProc could not get command info for test_ns_basic::createdcommand",
  785.             (char *) NULL);
  786.     return TCL_ERROR;
  787.     }
  788.     Tcl_AppendResult(interp, "CreatedCommandProc in ",
  789.         info.namespacePtr->fullName, (char *) NULL);
  790.     return TCL_OK;
  791. }
  792.  
  793. static int
  794. CreatedCommandProc2(clientData, interp, argc, argv)
  795.     ClientData clientData;        /* String to return. */
  796.     Tcl_Interp *interp;            /* Current interpreter. */
  797.     int argc;                /* Number of arguments. */
  798.     char **argv;            /* Argument strings. */
  799. {
  800.     Tcl_CmdInfo info;
  801.     int found;
  802.  
  803.     found = Tcl_GetCommandInfo(interp, "value:at:", &info);
  804.     if (!found) {
  805.     Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand",
  806.             (char *) NULL);
  807.     return TCL_ERROR;
  808.     }
  809.     Tcl_AppendResult(interp, "CreatedCommandProc2 in ",
  810.         info.namespacePtr->fullName, (char *) NULL);
  811.     return TCL_OK;
  812. }
  813.  
  814. /*
  815.  *----------------------------------------------------------------------
  816.  *
  817.  * TestdcallCmd --
  818.  *
  819.  *    This procedure implements the "testdcall" command.  It is used
  820.  *    to test Tcl_CallWhenDeleted.
  821.  *
  822.  * Results:
  823.  *    A standard Tcl result.
  824.  *
  825.  * Side effects:
  826.  *    Creates and deletes interpreters.
  827.  *
  828.  *----------------------------------------------------------------------
  829.  */
  830.  
  831.     /* ARGSUSED */
  832. static int
  833. TestdcallCmd(dummy, interp, argc, argv)
  834.     ClientData dummy;            /* Not used. */
  835.     Tcl_Interp *interp;            /* Current interpreter. */
  836.     int argc;                /* Number of arguments. */
  837.     char **argv;            /* Argument strings. */
  838. {
  839.     int i, id;
  840.  
  841.     delInterp = Tcl_CreateInterp();
  842.     Tcl_DStringInit(&delString);
  843.     for (i = 1; i < argc; i++) {
  844.     if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) {
  845.         return TCL_ERROR;
  846.     }
  847.     if (id < 0) {
  848.         Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc,
  849.             (ClientData) (-id));
  850.     } else {
  851.         Tcl_CallWhenDeleted(delInterp, DelCallbackProc,
  852.             (ClientData) id);
  853.     }
  854.     }
  855.     Tcl_DeleteInterp(delInterp);
  856.     Tcl_DStringResult(interp, &delString);
  857.     return TCL_OK;
  858. }
  859.  
  860. /*
  861.  * The deletion callback used by TestdcallCmd:
  862.  */
  863.  
  864. static void
  865. DelCallbackProc(clientData, interp)
  866.     ClientData clientData;        /* Numerical value to append to
  867.                      * delString. */
  868.     Tcl_Interp *interp;            /* Interpreter being deleted. */
  869. {
  870.     int id = (int) clientData;
  871.     char buffer[10];
  872.  
  873.     sprintf(buffer, "%d", id);
  874.     Tcl_DStringAppendElement(&delString, buffer);
  875.     if (interp != delInterp) {
  876.     Tcl_DStringAppendElement(&delString, "bogus interpreter argument!");
  877.     }
  878. }
  879.  
  880. /*
  881.  *----------------------------------------------------------------------
  882.  *
  883.  * TestdelCmd --
  884.  *
  885.  *    This procedure implements the "testdcall" command.  It is used
  886.  *    to test Tcl_CallWhenDeleted.
  887.  *
  888.  * Results:
  889.  *    A standard Tcl result.
  890.  *
  891.  * Side effects:
  892.  *    Creates and deletes interpreters.
  893.  *
  894.  *----------------------------------------------------------------------
  895.  */
  896.  
  897.     /* ARGSUSED */
  898. static int
  899. TestdelCmd(dummy, interp, argc, argv)
  900.     ClientData dummy;            /* Not used. */
  901.     Tcl_Interp *interp;            /* Current interpreter. */
  902.     int argc;                /* Number of arguments. */
  903.     char **argv;            /* Argument strings. */
  904. {
  905.     DelCmd *dPtr;
  906.     Tcl_Interp *slave;
  907.  
  908.     if (argc != 4) {
  909.     Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
  910.     return TCL_ERROR;
  911.     }
  912.  
  913.     slave = Tcl_GetSlave(interp, argv[1]);
  914.     if (slave == NULL) {
  915.     return TCL_ERROR;
  916.     }
  917.  
  918.     dPtr = (DelCmd *) ckalloc(sizeof(DelCmd));
  919.     dPtr->interp = interp;
  920.     dPtr->deleteCmd = (char *) ckalloc((unsigned) (strlen(argv[3]) + 1));
  921.     strcpy(dPtr->deleteCmd, argv[3]);
  922.  
  923.     Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr,
  924.         DelDeleteProc);
  925.     return TCL_OK;
  926. }
  927.  
  928. static int
  929. DelCmdProc(clientData, interp, argc, argv)
  930.     ClientData clientData;        /* String result to return. */
  931.     Tcl_Interp *interp;            /* Current interpreter. */
  932.     int argc;                /* Number of arguments. */
  933.     char **argv;            /* Argument strings. */
  934. {
  935.     DelCmd *dPtr = (DelCmd *) clientData;
  936.  
  937.     Tcl_AppendResult(interp, dPtr->deleteCmd, (char *) NULL);
  938.     ckfree(dPtr->deleteCmd);
  939.     ckfree((char *) dPtr);
  940.     return TCL_OK;
  941. }
  942.  
  943. static void
  944. DelDeleteProc(clientData)
  945.     ClientData clientData;        /* String command to evaluate. */
  946. {
  947.     DelCmd *dPtr = (DelCmd *) clientData;
  948.  
  949.     Tcl_Eval(dPtr->interp, dPtr->deleteCmd);
  950.     Tcl_ResetResult(dPtr->interp);
  951.     ckfree(dPtr->deleteCmd);
  952.     ckfree((char *) dPtr);
  953. }
  954.  
  955. /*
  956.  *----------------------------------------------------------------------
  957.  *
  958.  * TestdelassocdataCmd --
  959.  *
  960.  *    This procedure implements the "testdelassocdata" command. It is used
  961.  *    to test Tcl_DeleteAssocData.
  962.  *
  963.  * Results:
  964.  *    A standard Tcl result.
  965.  *
  966.  * Side effects:
  967.  *    Deletes an association between a key and associated data from an
  968.  *    interpreter.
  969.  *
  970.  *----------------------------------------------------------------------
  971.  */
  972.  
  973. static int
  974. TestdelassocdataCmd(clientData, interp, argc, argv)
  975.     ClientData clientData;        /* Not used. */
  976.     Tcl_Interp *interp;            /* Current interpreter. */
  977.     int argc;                /* Number of arguments. */
  978.     char **argv;            /* Argument strings. */
  979. {
  980.     if (argc != 2) {
  981.         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  982.                 " data_key\"", (char *) NULL);
  983.         return TCL_ERROR;
  984.     }
  985.     Tcl_DeleteAssocData(interp, argv[1]);
  986.     return TCL_OK;
  987. }
  988.  
  989. /*
  990.  *----------------------------------------------------------------------
  991.  *
  992.  * TestdstringCmd --
  993.  *
  994.  *    This procedure implements the "testdstring" command.  It is used
  995.  *    to test the dynamic string facilities of Tcl.
  996.  *
  997.  * Results:
  998.  *    A standard Tcl result.
  999.  *
  1000.  * Side effects:
  1001.  *    Creates, deletes, and invokes handlers.
  1002.  *
  1003.  *----------------------------------------------------------------------
  1004.  */
  1005.  
  1006.     /* ARGSUSED */
  1007. static int
  1008. TestdstringCmd(dummy, interp, argc, argv)
  1009.     ClientData dummy;            /* Not used. */
  1010.     Tcl_Interp *interp;            /* Current interpreter. */
  1011.     int argc;                /* Number of arguments. */
  1012.     char **argv;            /* Argument strings. */
  1013. {
  1014.     int count;
  1015.  
  1016.     if (argc < 2) {
  1017.     wrongNumArgs:
  1018.     Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
  1019.     return TCL_ERROR;
  1020.     }
  1021.     if (strcmp(argv[1], "append") == 0) {
  1022.     if (argc != 4) {
  1023.         goto wrongNumArgs;
  1024.     }
  1025.     if (Tcl_GetInt(interp, argv[3], &count) != TCL_OK) {
  1026.         return TCL_ERROR;
  1027.     }
  1028.     Tcl_DStringAppend(&dstring, argv[2], count);
  1029.     } else if (strcmp(argv[1], "element") == 0) {
  1030.     if (argc != 3) {
  1031.         goto wrongNumArgs;
  1032.     }
  1033.     Tcl_DStringAppendElement(&dstring, argv[2]);
  1034.     } else if (strcmp(argv[1], "end") == 0) {
  1035.     if (argc != 2) {
  1036.         goto wrongNumArgs;
  1037.     }
  1038.     Tcl_DStringEndSublist(&dstring);
  1039.     } else if (strcmp(argv[1], "free") == 0) {
  1040.     if (argc != 2) {
  1041.         goto wrongNumArgs;
  1042.     }
  1043.     Tcl_DStringFree(&dstring);
  1044.     } else if (strcmp(argv[1], "get") == 0) {
  1045.     if (argc != 2) {
  1046.         goto wrongNumArgs;
  1047.     }
  1048.     Tcl_SetResult(interp, Tcl_DStringValue(&dstring), TCL_VOLATILE);
  1049.     } else if (strcmp(argv[1], "gresult") == 0) {
  1050.     if (argc != 3) {
  1051.         goto wrongNumArgs;
  1052.     }
  1053.     if (strcmp(argv[2], "staticsmall") == 0) {
  1054.         Tcl_SetResult(interp, "short", TCL_STATIC);
  1055.     } else if (strcmp(argv[2], "staticlarge") == 0) {
  1056.         Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC);
  1057.     } else if (strcmp(argv[2], "free") == 0) {
  1058.         Tcl_SetResult(interp, (char *) ckalloc(100), TCL_DYNAMIC);
  1059.         strcpy(interp->result, "This is a malloc-ed string");
  1060.     } else if (strcmp(argv[2], "special") == 0) {
  1061.         interp->result = (char *) ckalloc(100);
  1062.         interp->result += 4;
  1063.         interp->freeProc = SpecialFree;
  1064.         strcpy(interp->result, "This is a specially-allocated string");
  1065.     } else {
  1066.         Tcl_AppendResult(interp, "bad gresult option \"", argv[2],
  1067.             "\": must be staticsmall, staticlarge, free, or special",
  1068.             (char *) NULL);
  1069.         return TCL_ERROR;
  1070.     }
  1071.     Tcl_DStringGetResult(interp, &dstring);
  1072.     } else if (strcmp(argv[1], "length") == 0) {
  1073.     char buf[30];
  1074.     
  1075.     if (argc != 2) {
  1076.         goto wrongNumArgs;
  1077.     }
  1078.     sprintf(buf, "%d", Tcl_DStringLength(&dstring));
  1079.     Tcl_SetResult(interp, buf, TCL_VOLATILE);
  1080.     } else if (strcmp(argv[1], "result") == 0) {
  1081.     if (argc != 2) {
  1082.         goto wrongNumArgs;
  1083.     }
  1084.     Tcl_DStringResult(interp, &dstring);
  1085.     } else if (strcmp(argv[1], "trunc") == 0) {
  1086.     if (argc != 3) {
  1087.         goto wrongNumArgs;
  1088.     }
  1089.     if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
  1090.         return TCL_ERROR;
  1091.     }
  1092.     Tcl_DStringTrunc(&dstring, count);
  1093.     } else if (strcmp(argv[1], "start") == 0) {
  1094.     if (argc != 2) {
  1095.         goto wrongNumArgs;
  1096.     }
  1097.     Tcl_DStringStartSublist(&dstring);
  1098.     } else {
  1099.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1100.         "\": must be append, element, end, free, get, length, ",
  1101.         "result, trunc, or start", (char *) NULL);
  1102.     return TCL_ERROR;
  1103.     }
  1104.     return TCL_OK;
  1105. }
  1106.  
  1107. /*
  1108.  * The procedure below is used as a special freeProc to test how well
  1109.  * Tcl_DStringGetResult handles freeProc's other than free.
  1110.  */
  1111.  
  1112. static void SpecialFree(blockPtr)
  1113.     char *blockPtr;            /* Block to free. */
  1114. {
  1115.     ckfree(blockPtr - 4);
  1116. }
  1117.  
  1118. /*
  1119.  *----------------------------------------------------------------------
  1120.  *
  1121.  * TestexithandlerCmd --
  1122.  *
  1123.  *    This procedure implements the "testexithandler" command. It is
  1124.  *    used to test Tcl_CreateExitHandler and Tcl_DeleteExitHandler.
  1125.  *
  1126.  * Results:
  1127.  *    A standard Tcl result.
  1128.  *
  1129.  * Side effects:
  1130.  *    None.
  1131.  *
  1132.  *----------------------------------------------------------------------
  1133.  */
  1134.  
  1135. static int
  1136. TestexithandlerCmd(clientData, interp, argc, argv)
  1137.     ClientData clientData;        /* Not used. */
  1138.     Tcl_Interp *interp;            /* Current interpreter. */
  1139.     int argc;                /* Number of arguments. */
  1140.     char **argv;            /* Argument strings. */
  1141. {
  1142.     int value;
  1143.  
  1144.     if (argc != 3) {
  1145.     Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  1146.                 " create|delete value\"", (char *) NULL);
  1147.         return TCL_ERROR;
  1148.     }
  1149.     if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) {
  1150.     return TCL_ERROR;
  1151.     }
  1152.     if (strcmp(argv[1], "create") == 0) {
  1153.     Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
  1154.         (ClientData) value);
  1155.     } else if (strcmp(argv[1], "delete") == 0) {
  1156.     Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven,
  1157.         (ClientData) value);
  1158.     } else {
  1159.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1160.         "\": must be create or delete", (char *) NULL);
  1161.     return TCL_ERROR;
  1162.     }
  1163.     return TCL_OK;
  1164. }
  1165.  
  1166. static void
  1167. ExitProcOdd(clientData)
  1168.     ClientData clientData;        /* Integer value to print. */
  1169. {
  1170.     char buf[100];
  1171.  
  1172.     sprintf(buf, "odd %d\n", (int) clientData);
  1173.     write(1, buf, strlen(buf));
  1174. }
  1175.  
  1176. static void
  1177. ExitProcEven(clientData)
  1178.     ClientData clientData;        /* Integer value to print. */
  1179. {
  1180.     char buf[100];
  1181.  
  1182.     sprintf(buf, "even %d\n", (int) clientData);
  1183.     write(1, buf, strlen(buf));
  1184. }
  1185.  
  1186. /*
  1187.  *----------------------------------------------------------------------
  1188.  *
  1189.  * TestexprlongCmd --
  1190.  *
  1191.  *    This procedure verifies that Tcl_ExprLong does not modify the
  1192.  *    interpreter result if there is no error.
  1193.  *
  1194.  * Results:
  1195.  *    A standard Tcl result.
  1196.  *
  1197.  * Side effects:
  1198.  *    None.
  1199.  *
  1200.  *----------------------------------------------------------------------
  1201.  */
  1202.  
  1203. static int
  1204. TestexprlongCmd(clientData, interp, argc, argv)
  1205.     ClientData clientData;        /* Not used. */
  1206.     Tcl_Interp *interp;            /* Current interpreter. */
  1207.     int argc;                /* Number of arguments. */
  1208.     char **argv;            /* Argument strings. */
  1209. {
  1210.     long exprResult;
  1211.     char buf[30];
  1212.     int result;
  1213.     
  1214.     Tcl_SetResult(interp, "This is a result", TCL_STATIC);
  1215.     result = Tcl_ExprLong(interp, "4+1", &exprResult);
  1216.     if (result != TCL_OK) {
  1217.         return result;
  1218.     }
  1219.     sprintf(buf, ": %ld", exprResult);
  1220.     Tcl_AppendResult(interp, buf, NULL);
  1221.     return TCL_OK;
  1222. }
  1223.  
  1224. /*
  1225.  *----------------------------------------------------------------------
  1226.  *
  1227.  * TestexprstringCmd --
  1228.  *
  1229.  *    This procedure tests the basic operation of Tcl_ExprString.
  1230.  *
  1231.  * Results:
  1232.  *    A standard Tcl result.
  1233.  *
  1234.  * Side effects:
  1235.  *    None.
  1236.  *
  1237.  *----------------------------------------------------------------------
  1238.  */
  1239.  
  1240. static int
  1241. TestexprstringCmd(clientData, interp, argc, argv)
  1242.     ClientData clientData;        /* Not used. */
  1243.     Tcl_Interp *interp;            /* Current interpreter. */
  1244.     int argc;                /* Number of arguments. */
  1245.     char **argv;            /* Argument strings. */
  1246. {
  1247.     if (argc != 2) {
  1248.         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  1249.                 " expression\"", (char *) NULL);
  1250.         return TCL_ERROR;
  1251.     }
  1252.     return Tcl_ExprString(interp, argv[1]);
  1253. }
  1254.  
  1255. /*
  1256.  *----------------------------------------------------------------------
  1257.  *
  1258.  * TestgetassocdataCmd --
  1259.  *
  1260.  *    This procedure implements the "testgetassocdata" command. It is
  1261.  *    used to test Tcl_GetAssocData.
  1262.  *
  1263.  * Results:
  1264.  *    A standard Tcl result.
  1265.  *
  1266.  * Side effects:
  1267.  *    None.
  1268.  *
  1269.  *----------------------------------------------------------------------
  1270.  */
  1271.  
  1272. static int
  1273. TestgetassocdataCmd(clientData, interp, argc, argv)
  1274.     ClientData clientData;        /* Not used. */
  1275.     Tcl_Interp *interp;            /* Current interpreter. */
  1276.     int argc;                /* Number of arguments. */
  1277.     char **argv;            /* Argument strings. */
  1278. {
  1279.     char *res;
  1280.     
  1281.     if (argc != 2) {
  1282.         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  1283.                 " data_key\"", (char *) NULL);
  1284.         return TCL_ERROR;
  1285.     }
  1286.     res = (char *) Tcl_GetAssocData(interp, argv[1], NULL);
  1287.     if (res != NULL) {
  1288.         Tcl_AppendResult(interp, res, NULL);
  1289.     }
  1290.     return TCL_OK;
  1291. }
  1292.  
  1293. /*
  1294.  *----------------------------------------------------------------------
  1295.  *
  1296.  * TestgetplatformCmd --
  1297.  *
  1298.  *    This procedure implements the "testgetplatform" command. It is
  1299.  *    used to retrievel the value of the tclPlatform global variable.
  1300.  *
  1301.  * Results:
  1302.  *    A standard Tcl result.
  1303.  *
  1304.  * Side effects:
  1305.  *    None.
  1306.  *
  1307.  *----------------------------------------------------------------------
  1308.  */
  1309.  
  1310. static int
  1311. TestgetplatformCmd(clientData, interp, argc, argv)
  1312.     ClientData clientData;        /* Not used. */
  1313.     Tcl_Interp *interp;            /* Current interpreter. */
  1314.     int argc;                /* Number of arguments. */
  1315.     char **argv;            /* Argument strings. */
  1316. {
  1317.     static char *platformStrings[] = { "unix", "mac", "windows" };
  1318.     TclPlatformType *platform;
  1319.  
  1320. #ifdef __WIN32__
  1321.     platform = TclWinGetPlatform();
  1322. #else
  1323.     platform = &tclPlatform;
  1324. #endif
  1325.     
  1326.     if (argc != 1) {
  1327.         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  1328.         (char *) NULL);
  1329.         return TCL_ERROR;
  1330.     }
  1331.  
  1332.     Tcl_AppendResult(interp, platformStrings[*platform], NULL);
  1333.     return TCL_OK;
  1334. }
  1335.  
  1336. /*
  1337.  *----------------------------------------------------------------------
  1338.  *
  1339.  * TestinterpdeleteCmd --
  1340.  *
  1341.  *    This procedure tests the code in tclInterp.c that deals with
  1342.  *    interpreter deletion. It deletes a user-specified interpreter
  1343.  *    from the hierarchy, and subsequent code checks integrity.
  1344.  *
  1345.  * Results:
  1346.  *    A standard Tcl result.
  1347.  *
  1348.  * Side effects:
  1349.  *    Deletes one or more interpreters.
  1350.  *
  1351.  *----------------------------------------------------------------------
  1352.  */
  1353.  
  1354.     /* ARGSUSED */
  1355. static int
  1356. TestinterpdeleteCmd(dummy, interp, argc, argv)
  1357.     ClientData dummy;            /* Not used. */
  1358.     Tcl_Interp *interp;            /* Current interpreter. */
  1359.     int argc;                /* Number of arguments. */
  1360.     char **argv;            /* Argument strings. */
  1361. {
  1362.     Tcl_Interp *slaveToDelete;
  1363.  
  1364.     if (argc != 2) {
  1365.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1366.                 " path\"", (char *) NULL);
  1367.         return TCL_ERROR;
  1368.     }
  1369.     if (argv[1][0] == '\0') {
  1370.         Tcl_AppendResult(interp, "cannot delete current interpreter",
  1371.                 (char *) NULL);
  1372.         return TCL_ERROR;
  1373.     }
  1374.     slaveToDelete = Tcl_GetSlave(interp, argv[1]);
  1375.     if (slaveToDelete == (Tcl_Interp *) NULL) {
  1376.         Tcl_AppendResult(interp, "could not find interpreter \"",
  1377.                 argv[1], "\"", (char *) NULL);
  1378.         return TCL_ERROR;
  1379.     }
  1380.     Tcl_DeleteInterp(slaveToDelete);
  1381.     return TCL_OK;
  1382. }
  1383.  
  1384. /*
  1385.  *----------------------------------------------------------------------
  1386.  *
  1387.  * TestlinkCmd --
  1388.  *
  1389.  *    This procedure implements the "testlink" command.  It is used
  1390.  *    to test Tcl_LinkVar and related library procedures.
  1391.  *
  1392.  * Results:
  1393.  *    A standard Tcl result.
  1394.  *
  1395.  * Side effects:
  1396.  *    Creates and deletes various variable links, plus returns
  1397.  *    values of the linked variables.
  1398.  *
  1399.  *----------------------------------------------------------------------
  1400.  */
  1401.  
  1402.     /* ARGSUSED */
  1403. static int
  1404. TestlinkCmd(dummy, interp, argc, argv)
  1405.     ClientData dummy;            /* Not used. */
  1406.     Tcl_Interp *interp;            /* Current interpreter. */
  1407.     int argc;                /* Number of arguments. */
  1408.     char **argv;            /* Argument strings. */
  1409. {
  1410.     static int intVar = 43;
  1411.     static int boolVar = 4;
  1412.     static double realVar = 1.23;
  1413.     static char *stringVar = NULL;
  1414.     static int created = 0;
  1415.     char buffer[TCL_DOUBLE_SPACE];
  1416.     int writable, flag;
  1417.  
  1418.     if (argc < 2) {
  1419.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1420.         " option ?arg arg arg?\"", (char *) NULL);
  1421.     return TCL_ERROR;
  1422.     }
  1423.     if (strcmp(argv[1], "create") == 0) {
  1424.     if (created) {
  1425.         Tcl_UnlinkVar(interp, "int");
  1426.         Tcl_UnlinkVar(interp, "real");
  1427.         Tcl_UnlinkVar(interp, "bool");
  1428.         Tcl_UnlinkVar(interp, "string");
  1429.     }
  1430.     created = 1;
  1431.     if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) {
  1432.         return TCL_ERROR;
  1433.     }
  1434.     flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
  1435.     if (Tcl_LinkVar(interp, "int", (char *) &intVar,
  1436.         TCL_LINK_INT | flag) != TCL_OK) {
  1437.         return TCL_ERROR;
  1438.     }
  1439.     if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) {
  1440.         return TCL_ERROR;
  1441.     }
  1442.     flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
  1443.     if (Tcl_LinkVar(interp, "real", (char *) &realVar,
  1444.         TCL_LINK_DOUBLE | flag) != TCL_OK) {
  1445.         return TCL_ERROR;
  1446.     }
  1447.     if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) {
  1448.         return TCL_ERROR;
  1449.     }
  1450.     flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
  1451.     if (Tcl_LinkVar(interp, "bool", (char *) &boolVar,
  1452.         TCL_LINK_BOOLEAN | flag) != TCL_OK) {
  1453.         return TCL_ERROR;
  1454.     }
  1455.     if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) {
  1456.         return TCL_ERROR;
  1457.     }
  1458.     flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
  1459.     if (Tcl_LinkVar(interp, "string", (char *) &stringVar,
  1460.         TCL_LINK_STRING | flag) != TCL_OK) {
  1461.         return TCL_ERROR;
  1462.     }
  1463.     } else if (strcmp(argv[1], "delete") == 0) {
  1464.     Tcl_UnlinkVar(interp, "int");
  1465.     Tcl_UnlinkVar(interp, "real");
  1466.     Tcl_UnlinkVar(interp, "bool");
  1467.     Tcl_UnlinkVar(interp, "string");
  1468.     created = 0;
  1469.     } else if (strcmp(argv[1], "get") == 0) {
  1470.     sprintf(buffer, "%d", intVar);
  1471.     Tcl_AppendElement(interp, buffer);
  1472.     Tcl_PrintDouble((Tcl_Interp *) NULL, realVar, buffer);
  1473.     Tcl_AppendElement(interp, buffer);
  1474.     sprintf(buffer, "%d", boolVar);
  1475.     Tcl_AppendElement(interp, buffer);
  1476.     Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar);
  1477.     } else if (strcmp(argv[1], "set") == 0) {
  1478.     if (argc != 6) {
  1479.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1480.         argv[0], " ", argv[1],
  1481.         "intValue realValue boolValue stringValue\"", (char *) NULL);
  1482.         return TCL_ERROR;
  1483.     }
  1484.     if (argv[2][0] != 0) {
  1485.         if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) {
  1486.         return TCL_ERROR;
  1487.         }
  1488.     }
  1489.     if (argv[3][0] != 0) {
  1490.         if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) {
  1491.         return TCL_ERROR;
  1492.         }
  1493.     }
  1494.     if (argv[4][0] != 0) {
  1495.         if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
  1496.         return TCL_ERROR;
  1497.         }
  1498.     }
  1499.     if (argv[5][0] != 0) {
  1500.         if (stringVar != NULL) {
  1501.         ckfree(stringVar);
  1502.         }
  1503.         if (strcmp(argv[5], "-") == 0) {
  1504.         stringVar = NULL;
  1505.         } else {
  1506.         stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1));
  1507.         strcpy(stringVar, argv[5]);
  1508.         }
  1509.     }
  1510.     } else if (strcmp(argv[1], "update") == 0) {
  1511.     if (argc != 6) {
  1512.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1513.         argv[0], " ", argv[1],
  1514.         "intValue realValue boolValue stringValue\"", (char *) NULL);
  1515.         return TCL_ERROR;
  1516.     }
  1517.     if (argv[2][0] != 0) {
  1518.         if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) {
  1519.         return TCL_ERROR;
  1520.         }
  1521.         Tcl_UpdateLinkedVar(interp, "int");
  1522.     }
  1523.     if (argv[3][0] != 0) {
  1524.         if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) {
  1525.         return TCL_ERROR;
  1526.         }
  1527.         Tcl_UpdateLinkedVar(interp, "real");
  1528.     }
  1529.     if (argv[4][0] != 0) {
  1530.         if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
  1531.         return TCL_ERROR;
  1532.         }
  1533.         Tcl_UpdateLinkedVar(interp, "bool");
  1534.     }
  1535.     if (argv[5][0] != 0) {
  1536.         if (stringVar != NULL) {
  1537.         ckfree(stringVar);
  1538.         }
  1539.         if (strcmp(argv[5], "-") == 0) {
  1540.         stringVar = NULL;
  1541.         } else {
  1542.         stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1));
  1543.         strcpy(stringVar, argv[5]);
  1544.         }
  1545.         Tcl_UpdateLinkedVar(interp, "string");
  1546.     }
  1547.     } else {
  1548.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1549.         "\": should be create, delete, get, set, or update",
  1550.         (char *) NULL);
  1551.     return TCL_ERROR;
  1552.     }
  1553.     return TCL_OK;
  1554. }
  1555.  
  1556. /*
  1557.  *----------------------------------------------------------------------
  1558.  *
  1559.  * TestMathFunc --
  1560.  *
  1561.  *    This is a user-defined math procedure to test out math procedures
  1562.  *    with no arguments.
  1563.  *
  1564.  * Results:
  1565.  *    A normal Tcl completion code.
  1566.  *
  1567.  * Side effects:
  1568.  *    None.
  1569.  *
  1570.  *----------------------------------------------------------------------
  1571.  */
  1572.  
  1573.     /* ARGSUSED */
  1574. static int
  1575. TestMathFunc(clientData, interp, args, resultPtr)
  1576.     ClientData clientData;        /* Integer value to return. */
  1577.     Tcl_Interp *interp;            /* Not used. */
  1578.     Tcl_Value *args;            /* Not used. */
  1579.     Tcl_Value *resultPtr;        /* Where to store result. */
  1580. {
  1581.     resultPtr->type = TCL_INT;
  1582.     resultPtr->intValue = (int) clientData;
  1583.     return TCL_OK;
  1584. }
  1585.  
  1586. /*
  1587.  *----------------------------------------------------------------------
  1588.  *
  1589.  * TestMathFunc2 --
  1590.  *
  1591.  *    This is a user-defined math procedure to test out math procedures
  1592.  *    that do have arguments, in this case 2.
  1593.  *
  1594.  * Results:
  1595.  *    A normal Tcl completion code.
  1596.  *
  1597.  * Side effects:
  1598.  *    None.
  1599.  *
  1600.  *----------------------------------------------------------------------
  1601.  */
  1602.  
  1603.     /* ARGSUSED */
  1604. static int
  1605. TestMathFunc2(clientData, interp, args, resultPtr)
  1606.     ClientData clientData;        /* Integer value to return. */
  1607.     Tcl_Interp *interp;            /* Used to report errors. */
  1608.     Tcl_Value *args;            /* Points to an array of two
  1609.                      * Tcl_Values for the two
  1610.                      * arguments. */
  1611.     Tcl_Value *resultPtr;        /* Where to store the result. */
  1612. {
  1613.     int result = TCL_OK;
  1614.     
  1615.     /*
  1616.      * Return the maximum of the two arguments with the correct type.
  1617.      */
  1618.     
  1619.     if (args[0].type == TCL_INT) {
  1620.     int i0 = args[0].intValue;
  1621.     
  1622.     if (args[1].type == TCL_INT) {
  1623.         int i1 = args[1].intValue;
  1624.         
  1625.         resultPtr->type = TCL_INT;
  1626.         resultPtr->intValue = ((i0 > i1)? i0 : i1);
  1627.     } else if (args[1].type == TCL_DOUBLE) {
  1628.         double d0 = i0;
  1629.         double d1 = args[1].doubleValue;
  1630.  
  1631.         resultPtr->type = TCL_DOUBLE;
  1632.         resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
  1633.     } else {
  1634.         Tcl_SetResult(interp, "T2: wrong type for arg 2", TCL_STATIC);
  1635.         result = TCL_ERROR;
  1636.     }
  1637.     } else if (args[0].type == TCL_DOUBLE) {
  1638.     double d0 = args[0].doubleValue;
  1639.     
  1640.     if (args[1].type == TCL_INT) {
  1641.         double d1 = args[1].intValue;
  1642.         
  1643.         resultPtr->type = TCL_DOUBLE;
  1644.         resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
  1645.     } else if (args[1].type == TCL_DOUBLE) {
  1646.         double d1 = args[1].doubleValue;
  1647.  
  1648.         resultPtr->type = TCL_DOUBLE;
  1649.         resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
  1650.     } else {
  1651.         Tcl_SetResult(interp, "T2: wrong type for arg 2", TCL_STATIC);
  1652.         result = TCL_ERROR;
  1653.     }
  1654.     } else {
  1655.     Tcl_SetResult(interp, "T2: wrong type for arg 1", TCL_STATIC);
  1656.     result = TCL_ERROR;
  1657.     }
  1658.     return result;
  1659. }
  1660.  
  1661. /*
  1662.  *----------------------------------------------------------------------
  1663.  *
  1664.  * CleanupTestSetassocdataTests --
  1665.  *
  1666.  *    This function is called when an interpreter is deleted to clean
  1667.  *    up any data left over from running the testsetassocdata command.
  1668.  *
  1669.  * Results:
  1670.  *    None.
  1671.  *
  1672.  * Side effects:
  1673.  *    Releases storage.
  1674.  *
  1675.  *----------------------------------------------------------------------
  1676.  */
  1677.     /* ARGSUSED */
  1678. static void
  1679. CleanupTestSetassocdataTests(clientData, interp)
  1680.     ClientData clientData;        /* Data to be released. */
  1681.     Tcl_Interp *interp;            /* Interpreter being deleted. */
  1682. {
  1683.     ckfree((char *) clientData);
  1684. }
  1685.  
  1686. /*
  1687.  *----------------------------------------------------------------------
  1688.  *
  1689.  * TestsetassocdataCmd --
  1690.  *
  1691.  *    This procedure implements the "testsetassocdata" command. It is used
  1692.  *    to test Tcl_SetAssocData.
  1693.  *
  1694.  * Results:
  1695.  *    A standard Tcl result.
  1696.  *
  1697.  * Side effects:
  1698.  *    Modifies or creates an association between a key and associated
  1699.  *    data for this interpreter.
  1700.  *
  1701.  *----------------------------------------------------------------------
  1702.  */
  1703.  
  1704. static int
  1705. TestsetassocdataCmd(clientData, interp, argc, argv)
  1706.     ClientData clientData;        /* Not used. */
  1707.     Tcl_Interp *interp;            /* Current interpreter. */
  1708.     int argc;                /* Number of arguments. */
  1709.     char **argv;            /* Argument strings. */
  1710. {
  1711.     char *buf;
  1712.     char *oldData;
  1713.     Tcl_InterpDeleteProc *procPtr;
  1714.     
  1715.     if (argc != 3) {
  1716.         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  1717.                 " data_key data_item\"", (char *) NULL);
  1718.         return TCL_ERROR;
  1719.     }
  1720.  
  1721.     buf = ckalloc((unsigned) strlen(argv[2]) + 1);
  1722.     strcpy(buf, argv[2]);
  1723.  
  1724.     /*
  1725.      * If we previously associated a malloced value with the variable,
  1726.      * free it before associating a new value.
  1727.      */
  1728.  
  1729.     oldData = (char *) Tcl_GetAssocData(interp, argv[1], &procPtr);
  1730.     if ((oldData != NULL) && (procPtr == CleanupTestSetassocdataTests)) {
  1731.     ckfree(oldData);
  1732.     }
  1733.     
  1734.     Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, 
  1735.     (ClientData) buf);
  1736.     return TCL_OK;
  1737. }
  1738.  
  1739. /*
  1740.  *----------------------------------------------------------------------
  1741.  *
  1742.  * TestsetplatformCmd --
  1743.  *
  1744.  *    This procedure implements the "testsetplatform" command. It is
  1745.  *    used to change the tclPlatform global variable so all file
  1746.  *    name conversions can be tested on a single platform.
  1747.  *
  1748.  * Results:
  1749.  *    A standard Tcl result.
  1750.  *
  1751.  * Side effects:
  1752.  *    Sets the tclPlatform global variable.
  1753.  *
  1754.  *----------------------------------------------------------------------
  1755.  */
  1756.  
  1757. static int
  1758. TestsetplatformCmd(clientData, interp, argc, argv)
  1759.     ClientData clientData;        /* Not used. */
  1760.     Tcl_Interp *interp;            /* Current interpreter. */
  1761.     int argc;                /* Number of arguments. */
  1762.     char **argv;            /* Argument strings. */
  1763. {
  1764.     size_t length;
  1765.     TclPlatformType *platform;
  1766.  
  1767. #ifdef __WIN32__
  1768.     platform = TclWinGetPlatform();
  1769. #else
  1770.     platform = &tclPlatform;
  1771. #endif
  1772.     
  1773.     if (argc != 2) {
  1774.         Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
  1775.                 " platform\"", (char *) NULL);
  1776.         return TCL_ERROR;
  1777.     }
  1778.  
  1779.     length = strlen(argv[1]);
  1780.     if (strncmp(argv[1], "unix", length) == 0) {
  1781.     *platform = TCL_PLATFORM_UNIX;
  1782.     } else if (strncmp(argv[1], "mac", length) == 0) {
  1783.     *platform = TCL_PLATFORM_MAC;
  1784.     } else if (strncmp(argv[1], "windows", length) == 0) {
  1785.     *platform = TCL_PLATFORM_WINDOWS;
  1786.     } else {
  1787.         Tcl_AppendResult(interp, "unsupported platform: should be one of ",
  1788.         "unix, mac, or windows", (char *) NULL);
  1789.     return TCL_ERROR;
  1790.     }
  1791.     return TCL_OK;
  1792. }
  1793.  
  1794. /*
  1795.  *----------------------------------------------------------------------
  1796.  *
  1797.  * TeststaticpkgCmd --
  1798.  *
  1799.  *    This procedure implements the "teststaticpkg" command.
  1800.  *    It is used to test the procedure Tcl_StaticPackage.
  1801.  *
  1802.  * Results:
  1803.  *    A standard Tcl result.
  1804.  *
  1805.  * Side effects:
  1806.  *    When the packge given by argv[1] is loaded into an interpeter,
  1807.  *    variable "x" in that interpreter is set to "loaded".
  1808.  *
  1809.  *----------------------------------------------------------------------
  1810.  */
  1811.  
  1812. static int
  1813. TeststaticpkgCmd(dummy, interp, argc, argv)
  1814.     ClientData dummy;            /* Not used. */
  1815.     Tcl_Interp *interp;            /* Current interpreter. */
  1816.     int argc;                /* Number of arguments. */
  1817.     char **argv;            /* Argument strings. */
  1818. {
  1819.     int safe, loaded;
  1820.  
  1821.     if (argc != 4) {
  1822.     Tcl_AppendResult(interp, "wrong # arguments: should be \"",
  1823.         argv[0], " pkgName safe loaded\"", (char *) NULL);
  1824.     return TCL_ERROR;
  1825.     }
  1826.     if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) {
  1827.     return TCL_ERROR;
  1828.     }
  1829.     if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) {
  1830.     return TCL_ERROR;
  1831.     }
  1832.     Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc,
  1833.         (safe) ? StaticInitProc : NULL);
  1834.     return TCL_OK;
  1835. }
  1836.  
  1837. static int
  1838. StaticInitProc(interp)
  1839.     Tcl_Interp *interp;            /* Interpreter in which package
  1840.                      * is supposedly being loaded. */
  1841. {
  1842.     Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY);
  1843.     return TCL_OK;
  1844. }
  1845.  
  1846. /*
  1847.  *----------------------------------------------------------------------
  1848.  *
  1849.  * TesttranslatefilenameCmd --
  1850.  *
  1851.  *    This procedure implements the "testtranslatefilename" command.
  1852.  *    It is used to test the Tcl_TranslateFileName command.
  1853.  *
  1854.  * Results:
  1855.  *    A standard Tcl result.
  1856.  *
  1857.  * Side effects:
  1858.  *    None.
  1859.  *
  1860.  *----------------------------------------------------------------------
  1861.  */
  1862.  
  1863. static int
  1864. TesttranslatefilenameCmd(dummy, interp, argc, argv)
  1865.     ClientData dummy;            /* Not used. */
  1866.     Tcl_Interp *interp;            /* Current interpreter. */
  1867.     int argc;                /* Number of arguments. */
  1868.     char **argv;            /* Argument strings. */
  1869. {
  1870.     Tcl_DString buffer;
  1871.     char *result;
  1872.  
  1873.     if (argc != 2) {
  1874.     Tcl_AppendResult(interp, "wrong # arguments: should be \"",
  1875.         argv[0], " path\"", (char *) NULL);
  1876.     return TCL_ERROR;
  1877.     }
  1878.     result = Tcl_TranslateFileName(interp, argv[1], &buffer);
  1879.     if (result == NULL) {
  1880.     return TCL_ERROR;
  1881.     }
  1882.     Tcl_AppendResult(interp, result, NULL);
  1883.     Tcl_DStringFree(&buffer);
  1884.     return TCL_OK;
  1885. }
  1886.  
  1887. /*
  1888.  *----------------------------------------------------------------------
  1889.  *
  1890.  * TestupvarCmd --
  1891.  *
  1892.  *    This procedure implements the "testupvar2" command.  It is used
  1893.  *    to test Tcl_UpVar and Tcl_UpVar2.
  1894.  *
  1895.  * Results:
  1896.  *    A standard Tcl result.
  1897.  *
  1898.  * Side effects:
  1899.  *    Creates or modifies an "upvar" reference.
  1900.  *
  1901.  *----------------------------------------------------------------------
  1902.  */
  1903.  
  1904.     /* ARGSUSED */
  1905. static int
  1906. TestupvarCmd(dummy, interp, argc, argv)
  1907.     ClientData dummy;            /* Not used. */
  1908.     Tcl_Interp *interp;            /* Current interpreter. */
  1909.     int argc;                /* Number of arguments. */
  1910.     char **argv;            /* Argument strings. */
  1911. {
  1912.     int flags = 0;
  1913.     
  1914.     if ((argc != 5) && (argc != 6)) {
  1915.     Tcl_AppendResult(interp, "wrong # arguments: should be \"",
  1916.         argv[0], " level name ?name2? dest global\"", (char *) NULL);
  1917.     return TCL_ERROR;
  1918.     }
  1919.  
  1920.     if (argc == 5) {
  1921.     if (strcmp(argv[4], "global") == 0) {
  1922.         flags = TCL_GLOBAL_ONLY;
  1923.     } else if (strcmp(argv[4], "namespace") == 0) {
  1924.         flags = TCL_NAMESPACE_ONLY;
  1925.     }
  1926.     return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags);
  1927.     } else {
  1928.     if (strcmp(argv[5], "global") == 0) {
  1929.         flags = TCL_GLOBAL_ONLY;
  1930.     } else if (strcmp(argv[5], "namespace") == 0) {
  1931.         flags = TCL_NAMESPACE_ONLY;
  1932.     }
  1933.     return Tcl_UpVar2(interp, argv[1], argv[2], 
  1934.         (argv[3][0] == 0) ? (char *) NULL : argv[3], argv[4],
  1935.         flags);
  1936.     }
  1937. }
  1938.  
  1939. /*
  1940.  *----------------------------------------------------------------------
  1941.  *
  1942.  * TestwordendCmd --
  1943.  *
  1944.  *    This procedure implements the "testwordend" command.  It is used
  1945.  *    to test TclWordEnd.
  1946.  *
  1947.  * Results:
  1948.  *    A standard Tcl result.
  1949.  *
  1950.  * Side effects:
  1951.  *    None.
  1952.  *
  1953.  *----------------------------------------------------------------------
  1954.  */
  1955.  
  1956.     /* ARGSUSED */
  1957. static int
  1958. TestwordendObjCmd(dummy, interp, objc, objv)
  1959.     ClientData dummy;        /* Not used. */
  1960.     Tcl_Interp *interp;        /* Current interpreter. */
  1961.     int objc;            /* Number of arguments. */
  1962.     Tcl_Obj *CONST objv[];    /* The argument objects. */
  1963. {
  1964.     Tcl_Obj *objPtr;
  1965.     char *string, *end;
  1966.     int length;
  1967.  
  1968.     if (objc != 2) {
  1969.         Tcl_WrongNumArgs(interp, 1, objv, "string");
  1970.     return TCL_ERROR;
  1971.     }
  1972.     objPtr = Tcl_GetObjResult(interp);
  1973.     string = Tcl_GetStringFromObj(objv[1], &length);
  1974.     end = TclWordEnd(string, string+length, 0, NULL);
  1975.     Tcl_AppendToObj(objPtr, end, length - (end - string));
  1976.     return TCL_OK;
  1977. }
  1978.  
  1979. /*
  1980.  *----------------------------------------------------------------------
  1981.  *
  1982.  * TestsetobjerrorcodeCmd --
  1983.  *
  1984.  *    This procedure implements the "testsetobjerrorcodeCmd".
  1985.  *    This tests up to five elements passed to the
  1986.  *    Tcl_SetObjErrorCode command.
  1987.  *
  1988.  * Results:
  1989.  *    A standard Tcl result. Always returns TCL_ERROR so that
  1990.  *    the error code can be tested.
  1991.  *
  1992.  * Side effects:
  1993.  *    None.
  1994.  *
  1995.  *----------------------------------------------------------------------
  1996.  */
  1997.  
  1998.     /* ARGSUSED */
  1999. static int
  2000. TestsetobjerrorcodeCmd(dummy, interp, objc, objv)
  2001.     ClientData dummy;        /* Not used. */
  2002.     Tcl_Interp *interp;        /* Current interpreter. */
  2003.     int objc;            /* Number of arguments. */
  2004.     Tcl_Obj *CONST objv[];    /* The argument objects. */
  2005. {
  2006.     Tcl_Obj *listObjPtr;
  2007.  
  2008.     if (objc > 1) {
  2009.     listObjPtr = Tcl_ConcatObj(objc - 1, objv + 1);
  2010.     } else {
  2011.     listObjPtr = Tcl_NewObj();
  2012.     }
  2013.     Tcl_IncrRefCount(listObjPtr);
  2014.     Tcl_SetObjErrorCode(interp, listObjPtr);
  2015.     Tcl_DecrRefCount(listObjPtr);
  2016.     return TCL_ERROR;
  2017. }
  2018.  
  2019. /*
  2020.  *----------------------------------------------------------------------
  2021.  *
  2022.  * TestfeventCmd --
  2023.  *
  2024.  *    This procedure implements the "testfevent" command.  It is
  2025.  *    used for testing the "fileevent" command.
  2026.  *
  2027.  * Results:
  2028.  *    A standard Tcl result.
  2029.  *
  2030.  * Side effects:
  2031.  *    Creates and deletes interpreters.
  2032.  *
  2033.  *----------------------------------------------------------------------
  2034.  */
  2035.  
  2036.     /* ARGSUSED */
  2037. static int
  2038. TestfeventCmd(clientData, interp, argc, argv)
  2039.     ClientData clientData;        /* Not used. */
  2040.     Tcl_Interp *interp;            /* Current interpreter. */
  2041.     int argc;                /* Number of arguments. */
  2042.     char **argv;            /* Argument strings. */
  2043. {
  2044.     static Tcl_Interp *interp2 = NULL;
  2045.     int code;
  2046.     Tcl_Channel chan;
  2047.  
  2048.     if (argc < 2) {
  2049.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  2050.         " option ?arg arg ...?", (char *) NULL);
  2051.     return TCL_ERROR;
  2052.     }
  2053.     if (strcmp(argv[1], "cmd") == 0) {
  2054.     if (argc != 3) {
  2055.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  2056.             " cmd script", (char *) NULL);
  2057.         return TCL_ERROR;
  2058.     }
  2059.         if (interp2 != (Tcl_Interp *) NULL) {
  2060.             code = Tcl_GlobalEval(interp2, argv[2]);
  2061.             interp->result = interp2->result;
  2062.             return code;
  2063.         } else {
  2064.             Tcl_AppendResult(interp,
  2065.                     "called \"testfevent code\" before \"testfevent create\"",
  2066.                     (char *) NULL);
  2067.             return TCL_ERROR;
  2068.         }
  2069.     } else if (strcmp(argv[1], "create") == 0) {
  2070.     if (interp2 != NULL) {
  2071.             Tcl_DeleteInterp(interp2);
  2072.     }
  2073.         interp2 = Tcl_CreateInterp();
  2074.     return TCL_OK;
  2075.     } else if (strcmp(argv[1], "delete") == 0) {
  2076.     if (interp2 != NULL) {
  2077.             Tcl_DeleteInterp(interp2);
  2078.     }
  2079.     interp2 = NULL;
  2080.     } else if (strcmp(argv[1], "share") == 0) {
  2081.         if (interp2 != NULL) {
  2082.             chan = Tcl_GetChannel(interp, argv[2], NULL);
  2083.             if (chan == (Tcl_Channel) NULL) {
  2084.                 return TCL_ERROR;
  2085.             }
  2086.             Tcl_RegisterChannel(interp2, chan);
  2087.         }
  2088.     }
  2089.     
  2090.     return TCL_OK;
  2091. }
  2092.  
  2093. /*
  2094.  *----------------------------------------------------------------------
  2095.  *
  2096.  * TestPanicCmd --
  2097.  *
  2098.  *    Calls the panic routine.
  2099.  *
  2100.  * Results:
  2101.  *      Always returns TCL_OK. 
  2102.  *
  2103.  * Side effects:
  2104.  *    May exit application.
  2105.  *
  2106.  *----------------------------------------------------------------------
  2107.  */
  2108.  
  2109. static int
  2110. TestPanicCmd(dummy, interp, argc, argv)
  2111.     ClientData dummy;            /* Not used. */
  2112.     Tcl_Interp *interp;            /* Current interpreter. */
  2113.     int argc;                /* Number of arguments. */
  2114.     char **argv;            /* Argument strings. */
  2115. {
  2116.     char *argString;
  2117.     
  2118.     /*
  2119.      *  Put the arguments into a var args structure
  2120.      *  Append all of the arguments together separated by spaces
  2121.      */
  2122.  
  2123.     argString = Tcl_Merge(argc-1, argv+1);
  2124.     panic(argString);
  2125.     ckfree(argString);
  2126.  
  2127.     return TCL_OK;
  2128. }
  2129.  
  2130. /*
  2131.  *---------------------------------------------------------------------------
  2132.  *
  2133.  * TestchmodCmd --
  2134.  *
  2135.  *    Implements the "testchmod" cmd.  Used when testing "file"
  2136.  *    command.  The only attribute used by the Mac and Windows platforms
  2137.  *    is the user write flag; if this is not set, the file is
  2138.  *    made read-only.  Otehrwise, the file is made read-write.
  2139.  *
  2140.  * Results:
  2141.  *    A standard Tcl result.
  2142.  *
  2143.  * Side effects:
  2144.  *    Changes permissions of specified files.
  2145.  *
  2146.  *---------------------------------------------------------------------------
  2147.  */
  2148.  
  2149. static int
  2150. TestchmodCmd(dummy, interp, argc, argv)
  2151.     ClientData dummy;            /* Not used. */
  2152.     Tcl_Interp *interp;            /* Current interpreter. */
  2153.     int argc;                /* Number of arguments. */
  2154.     char **argv;            /* Argument strings. */
  2155. {
  2156.     int i, mode;
  2157.     char *rest;
  2158.  
  2159.     if (argc < 2) {
  2160.     usage:
  2161.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  2162.         " mode file ?file ...?", (char *) NULL);
  2163.     return TCL_ERROR;
  2164.     }
  2165.  
  2166.     mode = (int) strtol(argv[1], &rest, 8);
  2167.     if (*rest != '\0') {
  2168.     goto usage;
  2169.     }
  2170.  
  2171.     for (i = 2; i < argc; i++) {
  2172.         Tcl_DString buffer;
  2173.         
  2174.         argv[i] = Tcl_TranslateFileName(interp, argv[i], &buffer);
  2175.         if (argv[i] == NULL) {
  2176.             return TCL_ERROR;
  2177.         }
  2178.     if (chmod(argv[i], (unsigned) mode) != 0) {
  2179.         Tcl_AppendResult(interp, argv[i], ": ", Tcl_PosixError(interp),
  2180.             (char *) NULL);
  2181.         return TCL_ERROR;
  2182.     }
  2183.         Tcl_DStringFree(&buffer);
  2184.     }
  2185.     return TCL_OK;
  2186. }
  2187.  
  2188. static int
  2189. TestfileCmd(dummy, interp, argc, argv)
  2190.     ClientData dummy;            /* Not used. */
  2191.     Tcl_Interp *interp;            /* Current interpreter. */
  2192.     int argc;                /* Number of arguments. */
  2193.     char **argv;            /* Argument strings. */
  2194. {
  2195.     int force, i, j, result;
  2196.     Tcl_DString error, name[2];
  2197.     
  2198.     if (argc < 3) {
  2199.     return TCL_ERROR;
  2200.     }
  2201.  
  2202.     force = 0;
  2203.     i = 2;
  2204.     if (strcmp(argv[2], "-force") == 0) {
  2205.         force = 1;
  2206.     i = 3;
  2207.     }
  2208.  
  2209.     Tcl_DStringInit(&name[0]);
  2210.     Tcl_DStringInit(&name[1]);
  2211.     Tcl_DStringInit(&error);
  2212.  
  2213.     if (argc - i > 2) {
  2214.     return TCL_ERROR;
  2215.     }
  2216.  
  2217.     for (j = i; j < argc; j++) {
  2218.         argv[j] = Tcl_TranslateFileName(interp, argv[j], &name[j - i]);
  2219.     if (argv[j] == NULL) {
  2220.         return TCL_ERROR;
  2221.     }
  2222.     }
  2223.  
  2224.     if (strcmp(argv[1], "mv") == 0) {
  2225.     result = TclpRenameFile(argv[i], argv[i + 1]);
  2226.     } else if (strcmp(argv[1], "cp") == 0) {
  2227.         result = TclpCopyFile(argv[i], argv[i + 1]);
  2228.     } else if (strcmp(argv[1], "rm") == 0) {
  2229.         result = TclpDeleteFile(argv[i]);
  2230.     } else if (strcmp(argv[1], "mkdir") == 0) {
  2231.         result = TclpCreateDirectory(argv[i]);
  2232.     } else if (strcmp(argv[1], "cpdir") == 0) {
  2233.         result = TclpCopyDirectory(argv[i], argv[i + 1], &error);
  2234.     } else if (strcmp(argv[1], "rmdir") == 0) {
  2235.         result = TclpRemoveDirectory(argv[i], force, &error);
  2236.     } else {
  2237.         result = TCL_ERROR;
  2238.     goto end;
  2239.     }
  2240.     
  2241.     if (result != TCL_OK) {
  2242.     if (Tcl_DStringValue(&error)[0] != '\0') {
  2243.         Tcl_AppendResult(interp, Tcl_DStringValue(&error), " ", NULL);
  2244.     }
  2245.     Tcl_AppendResult(interp, Tcl_ErrnoId(), (char *) NULL);
  2246.     }
  2247.  
  2248.     end:
  2249.     Tcl_DStringFree(&error);
  2250.     Tcl_DStringFree(&name[0]);
  2251.     Tcl_DStringFree(&name[1]);
  2252.  
  2253.     return result;
  2254. }
  2255.  
  2256. /*
  2257.  *----------------------------------------------------------------------
  2258.  *
  2259.  * TestgetvarfullnameCmd --
  2260.  *
  2261.  *    Implements the "testgetvarfullname" cmd that is used when testing
  2262.  *    the Tcl_GetVariableFullName procedure.
  2263.  *
  2264.  * Results:
  2265.  *    A standard Tcl result.
  2266.  *
  2267.  * Side effects:
  2268.  *    None.
  2269.  *
  2270.  *----------------------------------------------------------------------
  2271.  */
  2272.  
  2273. static int
  2274. TestgetvarfullnameCmd(dummy, interp, objc, objv)
  2275.     ClientData dummy;        /* Not used. */
  2276.     Tcl_Interp *interp;        /* Current interpreter. */
  2277.     int objc;            /* Number of arguments. */
  2278.     Tcl_Obj *CONST objv[];    /* The argument objects. */
  2279. {
  2280.     char *name, *arg;
  2281.     int flags = 0;
  2282.     Tcl_Namespace *namespacePtr;
  2283.     Tcl_CallFrame frame;
  2284.     Tcl_Var variable;
  2285.     int result;
  2286.  
  2287.     if (objc != 3) {
  2288.     Tcl_WrongNumArgs(interp, 1, objv, "name scope");
  2289.         return TCL_ERROR;
  2290.     }
  2291.     
  2292.     name = Tcl_GetStringFromObj(objv[1], (int *) NULL);
  2293.  
  2294.     arg = Tcl_GetStringFromObj(objv[2], (int *) NULL);
  2295.     if (strcmp(arg, "global") == 0) {
  2296.     flags = TCL_GLOBAL_ONLY;
  2297.     } else if (strcmp(arg, "namespace") == 0) {
  2298.     flags = TCL_NAMESPACE_ONLY;
  2299.     }
  2300.  
  2301.     /*
  2302.      * This command, like any other created with Tcl_Create[Obj]Command,
  2303.      * runs in the global namespace. As a "namespace-aware" command that
  2304.      * needs to run in a particular namespace, it must activate that
  2305.      * namespace itself.
  2306.      */
  2307.  
  2308.     if (flags == TCL_NAMESPACE_ONLY) {
  2309.     namespacePtr = Tcl_FindNamespace(interp, "::test_ns_var",
  2310.             (Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG);
  2311.     if (namespacePtr == NULL) {
  2312.         return TCL_ERROR;
  2313.     }
  2314.     result = Tcl_PushCallFrame(interp, &frame, namespacePtr,
  2315.                 /*isProcCallFrame*/ 0);
  2316.     if (result != TCL_OK) {
  2317.         return result;
  2318.     }
  2319.     }
  2320.     
  2321.     variable = Tcl_FindNamespaceVar(interp, name, (Tcl_Namespace *) NULL,
  2322.         (flags | TCL_LEAVE_ERR_MSG));
  2323.  
  2324.     if (flags == TCL_NAMESPACE_ONLY) {
  2325.     Tcl_PopCallFrame(interp);
  2326.     }
  2327.     if (variable == (Tcl_Var) NULL) {
  2328.     return TCL_ERROR;
  2329.     }
  2330.     Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp));
  2331.     return TCL_OK;
  2332. }
  2333.  
  2334. /*
  2335.  *----------------------------------------------------------------------
  2336.  *
  2337.  * GetTimesCmd --
  2338.  *
  2339.  *    This procedure implements the "gettimes" command.  It is
  2340.  *    used for computing the time needed for various basic operations
  2341.  *    such as reading variables, allocating memory, sprintf, converting
  2342.  *    variables, etc.
  2343.  *
  2344.  * Results:
  2345.  *    A standard Tcl result.
  2346.  *
  2347.  * Side effects:
  2348.  *    Allocates and frees memory, sets a variable "a" in the interpreter.
  2349.  *
  2350.  *----------------------------------------------------------------------
  2351.  */
  2352.  
  2353. static int
  2354. GetTimesCmd(unused, interp, argc, argv)
  2355.     ClientData unused;        /* Unused. */
  2356.     Tcl_Interp *interp;        /* The current interpreter. */
  2357.     int argc;            /* The number of arguments. */
  2358.     char **argv;        /* The argument strings. */
  2359. {
  2360.     Interp *iPtr = (Interp *) interp;
  2361.     int i, n;
  2362.     double timePer;
  2363.     Tcl_Time start, stop;
  2364.     Tcl_Obj *objPtr;
  2365.     Tcl_Obj **objv;
  2366.     char *s;
  2367.     char newString[30];
  2368.  
  2369.     /* alloc & free 100000 times */
  2370.     fprintf(stderr, "alloc & free 100000 6 word items\n");
  2371.     TclpGetTime(&start);
  2372.     for (i = 0;  i < 100000;  i++) {
  2373.     objPtr = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj));
  2374.     ckfree((char *) objPtr);
  2375.     }
  2376.     TclpGetTime(&stop);
  2377.     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
  2378.     fprintf(stderr, "   %.3f usec per alloc+free\n", timePer/100000);
  2379.     
  2380.     /* alloc 5000 times */
  2381.     fprintf(stderr, "alloc 5000 6 word items\n");
  2382.     objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *));
  2383.     TclpGetTime(&start);
  2384.     for (i = 0;  i < 5000;  i++) {
  2385.     objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj));
  2386.     }
  2387.     TclpGetTime(&stop);
  2388.     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
  2389.     fprintf(stderr, "   %.3f usec per alloc\n", timePer/5000);
  2390.     
  2391.     /* free 5000 times */
  2392.     fprintf(stderr, "free 5000 6 word items\n");
  2393.     TclpGetTime(&start);
  2394.     for (i = 0;  i < 5000;  i++) {
  2395.     ckfree((char *) objv[i]);
  2396.     }
  2397.     TclpGetTime(&stop);
  2398.     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
  2399.     fprintf(stderr, "   %.3f usec per free\n", timePer/5000);
  2400.  
  2401.     /* Tcl_NewObj 5000 times */
  2402.     fprintf(stderr, "Tcl_NewObj 5000 times\n");
  2403.     TclpGetTime(&start);
  2404.     for (i = 0;  i < 5000;  i++) {
  2405.     objv[i] = Tcl_NewObj();
  2406.     }
  2407.     TclpGetTime(&stop);
  2408.     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
  2409.     fprintf(stderr, "   %.3f usec per Tcl_NewObj\n", timePer/5000);
  2410.     
  2411.     /* Tcl_DecrRefCount 5000 times */
  2412.     fprintf(stderr, "Tcl_DecrRefCount 5000 times\n");
  2413.     TclpGetTime(&start);
  2414.     for (i = 0;  i < 5000;  i++) {
  2415.     objPtr = objv[i];
  2416.     Tcl_DecrRefCount(objPtr);
  2417.     }
  2418.     TclpGetTime(&stop);
  2419.     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
  2420.     fprintf(stderr, "   %.3f usec per Tcl_DecrRefCount\n", timePer/5000);
  2421.     ckfree((char *) objv);
  2422.  
  2423.     /* TclGetStringFromObj 100000 times */
  2424.     fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n");
  2425.     objPtr = Tcl_NewStringObj("12345", -1);
  2426.     TclpGetTime(&start);
  2427.     for (i = 0;  i < 100000;  i++) {
  2428.     (void) TclGetStringFromObj(objPtr, &n);
  2429.     }
  2430.     TclpGetTime(&stop);
  2431.     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
  2432.     fprintf(stderr, "   %.3f usec per TclGetStringFromObj of \"12345\"\n",
  2433.         timePer/100000);
  2434.  
  2435.     /* Tcl_GetIntFromObj 100000 times */
  2436.     fprintf(stderr, "Tcl_GetIntFromObj of \"12345\" 100000 times\n");
  2437.     TclpGetTime(&start);
  2438.     for (i = 0;  i < 100000;  i++) {
  2439.     if (Tcl_GetIntFromObj(interp, objPtr, &n) != TCL_OK) {
  2440.         return TCL_ERROR;
  2441.     }
  2442.     }
  2443.     TclpGetTime(&stop);
  2444.     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
  2445.     fprintf(stderr, "   %.3f usec per Tcl_GetIntFromObj of \"12345\"\n",
  2446.         timePer/100000);
  2447.     Tcl_DecrRefCount(objPtr);
  2448.     
  2449.     /* Tcl_GetInt 100000 times */
  2450.     fprintf(stderr, "Tcl_GetInt of \"12345\" 100000 times\n");
  2451.     TclpGetTime(&start);
  2452.     for (i = 0;  i < 100000;  i++) {
  2453.     if (Tcl_GetInt(interp, "12345", &n) != TCL_OK) {
  2454.         return TCL_ERROR;
  2455.     }
  2456.     }
  2457.     TclpGetTime(&stop);
  2458.     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
  2459.     fprintf(stderr, "   %.3f usec per Tcl_GetInt of \"12345\"\n",
  2460.         timePer/100000);
  2461.  
  2462.     /* sprintf 100000 times */
  2463.     fprintf(stderr, "sprintf of 12345 100000 times\n");
  2464.     TclpGetTime(&start);
  2465.     for (i = 0;  i < 100000;  i++) {
  2466.     sprintf(newString, "%d", 12345);
  2467.     }
  2468.     TclpGetTime(&stop);
  2469.     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
  2470.     fprintf(stderr, "   %.3f usec per sprintf of 12345\n",
  2471.         timePer/100000);
  2472.  
  2473.     /* hashtable lookup 100000 times */
  2474.     fprintf(stderr, "hashtable lookup of \"gettimes\" 100000 times\n");
  2475.     TclpGetTime(&start);
  2476.     for (i = 0;  i < 100000;  i++) {
  2477.     (void) Tcl_FindHashEntry(&iPtr->globalNsPtr->cmdTable, "gettimes");
  2478.     }
  2479.     TclpGetTime(&stop);
  2480.     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
  2481.     fprintf(stderr, "   %.3f usec per hashtable lookup of \"gettimes\"\n",
  2482.         timePer/100000);
  2483.  
  2484.     /* Tcl_SetVar 100000 times */
  2485.     fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n");
  2486.     TclpGetTime(&start);
  2487.     for (i = 0;  i < 100000;  i++) {
  2488.     s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG);
  2489.     if (s == NULL) {
  2490.         return TCL_ERROR;
  2491.     }
  2492.     }
  2493.     TclpGetTime(&stop);
  2494.     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
  2495.     fprintf(stderr, "   %.3f usec per Tcl_SetVar of a to \"12345\"\n",
  2496.         timePer/100000);
  2497.  
  2498.     /* Tcl_GetVar 100000 times */
  2499.     fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n");
  2500.     TclpGetTime(&start);
  2501.     for (i = 0;  i < 100000;  i++) {
  2502.     s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG);
  2503.     if (s == NULL) {
  2504.         return TCL_ERROR;
  2505.     }
  2506.     }
  2507.     TclpGetTime(&stop);
  2508.     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
  2509.     fprintf(stderr, "   %.3f usec per Tcl_GetVar of a==\"12345\"\n",
  2510.         timePer/100000);
  2511.     
  2512.     Tcl_ResetResult(interp);
  2513.     return TCL_OK;
  2514. }
  2515.  
  2516. /*
  2517.  *----------------------------------------------------------------------
  2518.  *
  2519.  * NoopCmd --
  2520.  *
  2521.  *    This procedure is just used to time the overhead involved in
  2522.  *    parsing and invoking a command.
  2523.  *
  2524.  * Results:
  2525.  *    None.
  2526.  *
  2527.  * Side effects:
  2528.  *    None.
  2529.  *
  2530.  *----------------------------------------------------------------------
  2531.  */
  2532.  
  2533. static int
  2534. NoopCmd(unused, interp, argc, argv)
  2535.     ClientData unused;        /* Unused. */
  2536.     Tcl_Interp *interp;        /* The current interpreter. */
  2537.     int argc;            /* The number of arguments. */
  2538.     char **argv;        /* The argument strings. */
  2539. {
  2540.     return TCL_OK;
  2541. }
  2542.  
  2543. /*
  2544.  *----------------------------------------------------------------------
  2545.  *
  2546.  * NoopObjCmd --
  2547.  *
  2548.  *    This object-based procedure is just used to time the overhead
  2549.  *    involved in parsing and invoking a command.
  2550.  *
  2551.  * Results:
  2552.  *    Returns the TCL_OK result code.
  2553.  *
  2554.  * Side effects:
  2555.  *    None.
  2556.  *
  2557.  *----------------------------------------------------------------------
  2558.  */
  2559.  
  2560. static int
  2561. NoopObjCmd(unused, interp, objc, objv)
  2562.     ClientData unused;        /* Not used. */
  2563.     Tcl_Interp *interp;        /* Current interpreter. */
  2564.     int objc;            /* Number of arguments. */
  2565.     Tcl_Obj *CONST objv[];    /* The argument objects. */
  2566. {
  2567.     return TCL_OK;
  2568. }
  2569.  
  2570. /*
  2571.  *----------------------------------------------------------------------
  2572.  *
  2573.  * TestsetnoerrCmd --
  2574.  *
  2575.  *    Implements the "testsetnoerr" cmd that is used when testing
  2576.  *    the Tcl_Set/GetVar C Api without TCL_LEAVE_ERR_MSG flag
  2577.  *
  2578.  * Results:
  2579.  *    A standard Tcl result.
  2580.  *
  2581.  * Side effects:
  2582.  *    None.
  2583.  *
  2584.  *----------------------------------------------------------------------
  2585.  */
  2586.  
  2587.     /* ARGSUSED */
  2588. static int
  2589. TestsetnoerrCmd(dummy, interp, argc, argv)
  2590.     ClientData dummy;            /* Not used. */
  2591.     register Tcl_Interp *interp;    /* Current interpreter. */
  2592.     int argc;                /* Number of arguments. */
  2593.     char **argv;            /* Argument strings. */
  2594. {
  2595.     char *value;
  2596.     if (argc == 2) {
  2597.     Tcl_SetResult(interp, "before get", TCL_STATIC);
  2598.     value = Tcl_GetVar2(interp, argv[1], (char *) NULL, TCL_PARSE_PART1);
  2599.     if (value == NULL) {
  2600.         return TCL_ERROR;
  2601.     }
  2602.     Tcl_SetResult(interp, value, TCL_VOLATILE);
  2603.     return TCL_OK;
  2604.     } else if (argc == 3) {
  2605.     char *m1 = "before set";
  2606.     char *message=Tcl_Alloc(strlen(m1)+1);
  2607.     
  2608.     strcpy(message,m1);
  2609.  
  2610.     Tcl_SetResult(interp, message, TCL_DYNAMIC);
  2611.  
  2612.     value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2],
  2613.                     TCL_PARSE_PART1);
  2614.     if (value == NULL) {
  2615.         return TCL_ERROR;
  2616.     }
  2617.     Tcl_SetResult(interp, value, TCL_VOLATILE);
  2618.     return TCL_OK;
  2619.     } else {
  2620.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  2621.         argv[0], " varName ?newValue?\"", (char *) NULL);
  2622.     return TCL_ERROR;
  2623.     }
  2624. }
  2625.  
  2626.